Inadvertently removed

trunksqlscript.pas

@@ -0,0 +1,691 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    Abstract SQL scripting engine.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{ This is unit sqlscript from FPC trunk/2.7.1}
+unit trunksqlscript;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+
+  TSQLScriptStatementEvent = procedure(Sender: TObject; Statement: TStrings; var StopExecution: Boolean) of object;
+  TSQLScriptDirectiveEvent = procedure(Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean) of object;
+  TSQLScriptExceptionEvent = procedure(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean) of object;
+  TSQLSkipMode = (smNone, smIfBranch, smElseBranch, smAll);
+
+  { TTrunkCustomSQLScript }
+
+  TTrunkCustomSQLScript = class(TComponent)
+  private
+    FAutoCommit: Boolean;
+    FLine: Integer;
+    FCol: Integer;
+    FDefines: TStrings;
+    FOnException: TSQLScriptExceptionEvent;
+    FSkipMode: TSQLSkipMode;
+    FIsSkipping: Boolean;
+    FSkipStackIndex: Integer;
+    FSkipModeStack: array[0..255] of TSQLSkipMode;
+    FIsSkippingStack: array[0..255] of Boolean;
+    FAborted: Boolean;
+    FUseSetTerm, FUseDefines, FUseCommit,
+    FCommentsInSQL: Boolean;
+    FTerminator: AnsiString;
+    FSQL: TStrings;
+    FCurrentStatement: TStrings;
+    FDirectives: TStrings;
+    FEmitLine: Boolean;
+    procedure SetDefines(const Value: TStrings);
+    function FindNextSeparator(sep: array of string): AnsiString;
+    procedure AddToStatement(value: AnsiString; ForceNewLine : boolean);
+    procedure SetDirectives(value: TStrings);
+    procedure SetSQL(value: TStrings);
+    procedure SQLChange(Sender: TObject);
+    function GetLine: Integer;
+    Function ProcessConditional(Directive : String; Param : String) : Boolean; virtual;
+    function NextStatement: AnsiString;
+    procedure ProcessStatement;
+    function Available: Boolean;
+    procedure InternalStatement (Statement: TStrings; var StopExecution: Boolean);
+    procedure InternalDirective (Directive, Argument: String; var StopExecution: Boolean);
+    // Runs commit. If ComitRetaining, use CommitRetraining if possible, else stop/starttransaction
+    procedure InternalCommit(CommitRetaining: boolean=true);
+  protected
+    procedure DefaultDirectives; virtual;
+    procedure ExecuteStatement (Statement: TStrings; var StopExecution: Boolean); virtual; abstract;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); virtual; abstract;
+    // Executes commit. If possible and CommitRetaining, use CommitRetaining, else
+    procedure ExecuteCommit(CommitRetaining: boolean=true); virtual; abstract;
+  public
+    constructor Create (AnOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Execute; virtual;
+  protected
+    property Aborted: Boolean read FAborted;
+    property Line: Integer read GetLine;
+    Property AutoCommit : Boolean Read FAutoCommit Write FAutoCommit;
+    property CommentsInSQL: Boolean read FCommentsInSQL write FCommentsInSQL;
+    property UseSetTerm: Boolean read FUseSetTerm write FUseSetTerm;
+    property UseCommit: Boolean read FUseCommit write FUseCommit;
+    property UseDefines: Boolean read FUseDefines write FUseDefines;
+    property Defines : TStrings Read FDefines Write SetDefines;
+    property Directives: TStrings read FDirectives write SetDirectives;
+    property Script: TStrings read FSQL write SetSQL;  // script to execute
+    property Terminator: AnsiString read FTerminator write FTerminator;
+    property OnException : TSQLScriptExceptionEvent read FOnException write FOnException;
+  end;
+
+  { TEventSQLScript }
+
+  TEventSQLScript = class (TTrunkCustomSQLScript)
+  private
+    FAfterExec: TNotifyEvent;
+    FBeforeExec: TNotifyEvent;
+    FOnCommit: TNotifyEvent;
+    FOnSQLStatement: TSQLScriptStatementEvent;
+    FOnDirective: TSQLScriptDirectiveEvent;
+  protected
+    procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
+    procedure ExecuteCommit(CommitRetaining: boolean=true); override;
+  public
+    procedure Execute; override;
+    property Aborted;
+    property Line;
+  published
+    property Directives;
+    property Defines;
+    property Script;
+    property Terminator;
+    property CommentsinSQL;
+    property UseSetTerm;
+    property UseCommit;
+    property UseDefines;
+    property OnException;
+    property OnSQLStatement: TSQLScriptStatementEvent read FOnSQLStatement write FOnSQLStatement;
+    property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
+    property OnCommit: TNotifyEvent read FOnCommit write FOnCommit;
+    property BeforeExecute : TNotifyEvent read FBeforeExec write FBeforeExec;
+    property AfterExecute : TNotifyEvent read FAfterExec write FAfterExec;
+  end;
+
+  ESQLScript = Class(Exception);
+
+implementation
+
+Resourcestring
+ SErrIfXXXNestingLimitReached = '#IFDEF nesting limit reached';
+ SErrInvalidEndif = '#ENDIF without #IFDEF';
+ SErrInvalidElse  = '#ELSE without #IFDEF';
+
+{ ---------------------------------------------------------------------
+    Auxiliary Functions
+  ---------------------------------------------------------------------}
+
+function StartsWith(S1, S2: AnsiString): Boolean;
+
+var
+  L1,L2 : Integer;
+
+begin
+  Result:=False;
+  L1:=Length(S1);
+  L2:=Length(S2);
+  if (L2=0) or (L1<L2) then
+    Exit;
+  Result:=(AnsiCompareStr(Copy(s1,1,L2),S2)=0);
+  Result := Result and ((L2 = L1) or (s1[L2+1] = ' '));
+end;
+
+function GetFirstSeparator(S: AnsiString; Sep: array of string): AnsiString;
+
+var
+  i, C, M: Integer;
+
+begin
+  M:=length(S) + 1;
+  Result:='';
+  for i:=0 to high(Sep) do
+    begin
+    C:=Pos(Sep[i],S);
+    if (C<>0) and (C<M) then
+      begin
+      M:=C;
+      Result:=Sep[i];
+      end;
+    end;
+end;
+
+Function ConvertWhiteSpace(S : String) : String;
+
+begin
+  Result:=StringReplace(S,#13,' ',[rfReplaceAll]);
+  Result:=StringReplace(Result,#10,' ',[rfReplaceAll]);
+  Result:=Trim(Result);
+end;
+
+function DeleteComments(SQL_Text: AnsiString; ATerminator: AnsiString = ';'): AnsiString;
+
+begin
+  With TTrunkCustomSQLScript.Create (Nil) do
+    try
+      Terminator:=ATerminator;
+      Script.Add(SQL_Text);
+      Script.Add(Terminator);
+      CommentsInSQL:=False;
+      Result:=ConvertWhiteSpace(NextStatement);
+    finally
+      Free;
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    TSQLScript
+  ---------------------------------------------------------------------}
+
+procedure TTrunkCustomSQLScript.SQLChange(Sender: TObject);
+begin
+  FLine:=1;
+  FCol:=1;
+end;
+
+procedure TTrunkCustomSQLScript.SetDirectives(value: TStrings);
+
+var
+  i : Integer;
+  S : AnsiString;
+
+begin
+  FDirectives.Clear();
+  if (Value<>Nil) then
+    begin
+    for i:=0 to value.Count - 1 do
+      begin
+      S:=UpperCase(ConvertWhiteSpace(value[i]));
+      if Length(S)>0 then
+        FDirectives.Add(S);
+      end;
+    end;
+  DefaultDirectives;
+end;
+
+procedure TTrunkCustomSQLScript.SetSQL(value: TStrings);
+begin
+  FSQL.Assign(value);
+  FLine:=1;
+  FCol:=1;
+end;
+
+function TTrunkCustomSQLScript.GetLine: Integer;
+begin
+  Result:=FLine - 1;
+end;
+
+procedure TTrunkCustomSQLScript.AddToStatement(value: AnsiString; ForceNewLine : Boolean);
+
+begin
+  With FCurrentStatement do
+    if ForceNewLine or (Count=0) then
+      Add(value)
+    else
+      Strings[Count-1]:=Strings[Count-1] + value;
+end;
+
+function TTrunkCustomSQLScript.FindNextSeparator(Sep: array of string): AnsiString;
+
+var
+  S: AnsiString;
+
+begin
+  Result:='';
+  while (FLine<=FSQL.Count) do
+    begin
+    S:=FSQL.Strings[FLine-1];
+    if (FCol>1) then
+      begin
+      S:=Copy(S,FCol,length(S));
+      end;
+    Result:=GetFirstSeparator(S,Sep);
+    if (Result='') then
+      begin
+      if FEmitLine then
+        AddToStatement(S,(FCol=1));
+      FCol:=1;
+      FLine:=FLine+1;
+      end
+    else
+      begin
+      if FEmitLine then
+        AddToStatement(Copy(S,1,Pos(Result,S)-1),(FCol=1));
+      FCol:=(FCol-1)+Pos(Result,S);
+      break;
+      end;
+    end;
+end;
+
+function TTrunkCustomSQLScript.Available: Boolean;
+
+var
+  SCol,
+  SLine: Integer;
+
+begin
+  SCol:=FCol;
+  SLine:=FLine;
+  try
+    Result:=Length(Trim(NextStatement()))>0;
+  Finally
+    FCol:=SCol;
+    FLine:=SLine;
+  end;
+end;
+
+procedure TTrunkCustomSQLScript.InternalStatement(Statement: TStrings;  var StopExecution: Boolean);
+
+var
+  cont : boolean;
+
+begin
+  try
+    ExecuteStatement(Statement, StopExecution);
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        FOnException (self, Statement, E, cont);
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TTrunkCustomSQLScript.InternalDirective(Directive, Argument: String;  var StopExecution: Boolean);
+
+var
+  cont : boolean;
+  l : TStrings;
+
+begin
+  try
+    ExecuteDirective(Directive, Argument, StopExecution);
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        begin
+        l := TStringlist.Create;
+        try
+          L.Add(Directive);
+          if Argument <> '' then
+            L.Add(Argument);
+          FOnException (self, l, E, cont);
+        finally
+          L.Free;
+        end;
+        end;
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TTrunkCustomSQLScript.InternalCommit(CommitRetaining: boolean=true);
+
+var
+  cont : boolean;
+  l : TStrings;
+
+begin
+  try
+    ExecuteCommit(CommitRetaining);
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        begin
+        l := TStringlist.Create;
+        try
+          L.Add('COMMIT');
+          FOnException (self, l, E, cont);
+        finally
+          L.Free;
+        end;
+        end;
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TTrunkCustomSQLScript.ProcessStatement;
+
+Var
+  S,
+  Directive : String;
+  I : longint;
+
+begin
+  if (FCurrentStatement.Count=0) then
+    Exit;
+  S:=DeleteComments(FCurrentStatement.Text, Terminator);
+  I:=0;
+  Directive:='';
+  While (i<FDirectives.Count) and (Directive='') do
+    begin
+    If StartsWith(AnsiUpperCase(S), FDirectives[i]) Then
+      Directive:=FDirectives[i];
+    Inc(I);
+    end;
+  If (Directive<>'') then
+    begin
+    S:=Trim(Copy(S,Length(Directive)+1,length(S)));
+    If (Directive[1]='#') then
+      begin
+      if not FUseDefines or not ProcessConditional(Directive,S) then
+        if Not FIsSkipping then
+          InternalDirective (Directive, S, FAborted);
+      end
+    else If Not FIsSkipping then
+      begin
+      // If AutoCommit, skip any explicit commits.
+      if FUseCommit
+        and ((Directive = 'COMMIT') or (Directive = 'COMMIT WORK' {SQL standard}))
+        and not FAutoCommit then
+        InternalCommit(false) //explicit commit, no commit retaining
+      else if FUseCommit
+        and (Directive = 'COMMIT RETAIN') {at least Firebird syntax}
+        and not FAutoCommit then
+        InternalCommit(true)
+      else if FUseSetTerm
+        and (Directive = 'SET TERM' {Firebird/Interbase only}) then
+        FTerminator:=S
+      else
+        InternalDirective (Directive,S,FAborted)
+      end
+    end
+  else
+    if (not FIsSkipping) then
+      begin
+      InternalStatement(FCurrentStatement,FAborted);
+      If FAutoCommit and not FAborted then
+        InternalCommit;
+      end;
+end;
+
+procedure TTrunkCustomSQLScript.Execute;
+
+begin
+  FSkipMode:=smNone;
+  FIsSkipping:=False;
+  FSkipStackIndex:=0;
+  Faborted:=False;
+  DefaultDirectives;
+  while not FAborted and Available() do
+    begin
+    NextStatement();
+    ProcessStatement;
+    end;
+end;
+
+function TTrunkCustomSQLScript.NextStatement: AnsiString;
+
+var
+  pnt: AnsiString;
+  terminator_found: Boolean;
+
+begin
+  terminator_found:=False;
+  FCurrentStatement.Clear;
+  while FLine <= FSQL.Count do
+    begin
+    pnt:=FindNextSeparator([FTerminator, '/*', '"', '''']);
+    if (pnt=FTerminator) then
+      begin
+      if pnt='' then
+      begin
+        // Empty line, only e.g. a ; present:
+        FEmitLine:=False;
+        end
+        else begin
+        FCol:=FCol + length(pnt);
+        terminator_found:=True;
+        break;
+        end;
+      end
+    else if pnt = '/*' then
+      begin
+      if FCommentsInSQL then
+        AddToStatement(pnt,false)
+      else
+        FEmitLine:=False;
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['*/']);
+      if FCommentsInSQL then
+        AddToStatement(pnt,false)
+      else
+        FEmitLine:=True;
+      FCol:=FCol + length(pnt);
+      end
+    else if pnt = '"' then
+      begin
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['"']);
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      end
+    else if pnt = '''' then
+      begin
+      AddToStatement(pnt,False);
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['''']);
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      end;
+    end;
+  if not terminator_found then
+    FCurrentStatement.Clear();
+  while (FCurrentStatement.Count > 0) and (trim(FCurrentStatement.Strings[0]) = '') do
+    FCurrentStatement.Delete(0);
+  Result:=FCurrentStatement.Text;
+end;
+
+Constructor TTrunkCustomSQLScript.Create (AnOwner: TComponent);
+
+Var
+  L : TStringList;
+
+begin
+  inherited;
+  L:=TStringList.Create;
+  With L do
+    begin
+    Sorted:=True;
+    Duplicates:=dupIgnore;
+    end;
+  FDefines:=L;
+  FCommentsInSQL:=True;
+  FTerminator:=';';
+  L:=TStringList.Create();
+  L.OnChange:=@SQLChange;
+  FSQL:=L;
+  FDirectives:=TStringList.Create();
+  FCurrentStatement:=TStringList.Create();
+  FLine:=1;
+  FCol:=1;
+  FEmitLine:=True;
+  FUseCommit := true;
+  FUseDefines := True;
+  FUseSetTerm := True;
+  DefaultDirectives;
+end;
+
+destructor TTrunkCustomSQLScript.Destroy;
+begin
+  FreeAndNil(FCurrentStatement);
+  FreeAndNil(FSQL);
+  FreeAndNil(FDirectives);
+  FreeAndNil(FDefines);
+  inherited Destroy;
+end;
+
+procedure TTrunkCustomSQLScript.SetDefines(const Value: TStrings);
+begin
+  FDefines.Assign(Value);
+end;
+
+procedure TTrunkCustomSQLScript.DefaultDirectives;
+begin
+  With FDirectives do
+    begin
+    // Insertion order matters as testing for directives will be done with StartsWith
+    if FUseSetTerm then
+      Add('SET TERM');
+    if FUseCommit then
+    begin
+      Add('COMMIT WORK'); {SQL Standard, equivalent to commit}
+      Add('COMMIT RETAIN'); {Firebird/Interbase; probably won't hurt on other dbs}
+      Add('COMMIT'); {Shorthand used in many dbs, e.g. Firebird}
+    end;
+    if FUseDefines then
+      begin
+      Add('#IFDEF');
+      Add('#IFNDEF');
+      Add('#ELSE');
+      Add('#ENDIF');
+      Add('#DEFINE');
+      Add('#UNDEF');
+      Add('#UNDEFINE');
+      end;
+    end;
+end;
+
+Function TTrunkCustomSQLScript.ProcessConditional(Directive: String; Param : String) : Boolean;
+
+  Procedure PushSkipMode;
+
+  begin
+    if FSkipStackIndex=High(FSkipModeStack) then
+      Raise ESQLScript.Create(SErrIfXXXNestingLimitReached);
+    FSkipModeStack[FSkipStackIndex]:=FSkipMode;
+    FIsSkippingStack[FSkipStackIndex]:=FIsSkipping;
+    Inc(FSkipStackIndex);
+  end;
+
+  Procedure PopSkipMode;
+
+  begin
+    if FSkipStackIndex = 0 then
+      Raise ESQLScript.Create(SErrInvalidEndif);
+    Dec(FSkipStackIndex);
+    FSkipMode := FSkipModeStack[FSkipStackIndex];
+    FIsSkipping := FIsSkippingStack[FSkipStackIndex];
+  end;
+
+Var
+  Index : Integer;
+
+begin
+  Result:=True;
+  if (Directive='#DEFINE') then
+    begin
+    if not FIsSkipping then
+      FDefines.Add(Param);
+    end
+  else if (Directive='#UNDEF') or (Directive='#UNDEFINE') then
+    begin
+    if not FIsSkipping then
+      begin
+      Index:=FDefines.IndexOf(Param);
+      if (Index>=0) then
+        FDefines.Delete(Index);
+      end;
+    end
+  else if (Directive='#IFDEF') or (Directive='#IFNDEF') then
+    begin
+    PushSkipMode;
+    if FIsSkipping then
+      begin
+      FSkipMode:=smAll;
+      FIsSkipping:=true;
+      end
+    else
+      begin
+      Index:=FDefines.IndexOf(Param);
+      if ((Directive='#IFDEF') and (Index<0)) or
+         ((Directive='#IFNDEF') and (Index>=0)) then
+        begin
+        FSkipMode:=smIfBranch;
+        FIsSkipping:=true;
+        end
+      else
+        FSkipMode := smElseBranch;
+      end;
+    end
+  else if (Directive='#ELSE') then
+    begin
+    if (FSkipStackIndex=0) then
+      Raise ESQLScript.Create(SErrInvalidElse);
+    if (FSkipMode=smIfBranch) then
+      FIsSkipping:=false
+    else if (FSkipMode=smElseBranch) then
+      FIsSkipping:=true;
+    end
+  else if (Directive='#ENDIF') then
+    PopSkipMode
+  else
+    Result:=False;
+end;
+
+{ TEventSQLScript }
+
+procedure TEventSQLScript.ExecuteStatement(SQLStatement: TStrings;
+  var StopExecution: Boolean);
+begin
+  if assigned (FOnSQLStatement) then
+    FOnSQLStatement (self, SQLStatement, StopExecution);
+end;
+
+procedure TEventSQLScript.ExecuteDirective(Directive, Argument: String;
+  var StopExecution: Boolean);
+begin
+  if assigned (FOnDirective) then
+    FOnDirective (Self, Directive, Argument, StopExecution);
+end;
+
+procedure TEventSQLScript.ExecuteCommit(CommitRetaining: boolean=true);
+begin
+  if assigned (FOnCommit) then
+    FOnCommit (Self);
+end;
+
+procedure TEventSQLScript.Execute;
+begin
+  if assigned (FBeforeExec) then
+    FBeforeExec (Self);
+  inherited Execute;
+  if assigned (FAfterExec) then
+    FAfterExec (Self);
+end;
+
+end.
+