trunk/runtime/ibxscript.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2014 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit ibxscript;

{$mode objfpc}{$H+}

interface

uses Classes, IBDatabase,  IBSQL, IBHeader;

type
  TSQLSymbol = (sqNone,sqSpace,sqSemiColon,sqSingleQuotes,sqDoubleQuotes,
                sqEnd,sqBegin,sqCommit,sqRollback,sqString,sqCommentStart,
                sqCommentEnd,sqCommentLine,sqAsterisk,sqForwardSlash,
                sqDeclare,sqEOL,sqTerminator, sqReconnect);

  TSQLStates =  (stInit, stError, stInSQL, stNested,stInSingleQuotes,
                 stInDoubleQuotes, stInComment, stInCommentLine,
                 stInDeclaration, stInCommit, stInReconnect);

  TGetParamValue = procedure(Sender: TObject; ParamName: string; var BlobID: TISC_QUAD) of object;
  TLogEvent = procedure(Sender: TObject; Msg: string) of Object;
  TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
  TOnSelectSQL = procedure (Sender: TObject; SQLText: string) of object;

  {
  TIBXScript: runs an SQL script in the specified file or stream. The text is parsed
  into SQL statements which are executed in turn. The intention is to be ISQL
  compatible but with extensions:

  * SET TERM and Set AutoDDL are both supported

  * New Command: RECONNECT. Performs a commit followed by disconnecting and
    reconnecting to the database.

  * Procedure Bodies (BEGIN .. END blocks) are self-delimiting and do not need
    an extra terminator. If a terminator is present, this is treated as an
    empty statement. The result is ISQL compatible, but does not require the
    use of SET TERM.

  * DML statements may have arguments in IBX format (e.g UPDATE MYTABLE Set data = :mydata).
    Arguments are valid only for BLOB columns and are resolved using the GetParamValue
    event. This returns the blobid to be used. A typical use of the event is to
    read binary data from a file, save it in a blob stream and return the blob id.

  Select SQL statements are not directly supported but can be handled by an external
  handler (OnSelectSQL event). If the handler is not present then an exception
  is raised if a Select SQL statement is found.

  Properties:

  * Database: Link to TIBDatabase component
  * Transaction: Link to Transaction. Defaults to internaltransaction (concurrency, wait)
  * Echo: boolean. When true, all SQL statements are echoed to log
  * StopOnFirstError: boolean. When true the script engine terminates on the first
    SQL Error.
  * IgnoreGrants: When true, grant statements are silently discarded. This can be
    useful when applying a script using the Embedded Server.


  Events:

  * GetParamValue: called when an SQL parameter is found (in PSQL :name format).
    This is only called for blob fields. Handler should return the BlobID to be
    used as the parameter value.  If not present an exception is raised when a
    parameter is found.
  * OnOutputLog: Called to write SQL Statements to the log (stdout)
  * OnErrorLog: Called to write all other messages to the log (stderr)
  * OnProgressEvent: Progress bar support. If Reset is true the value is maximum
    value of progress bar. Otherwise called to step progress bar.
  * OnSelectSQL: handler for select SQL statements. If not present, select SQL
    statements result in an exception.

  The PerformUpdate function is used to execute an SQL Script and may be called
  multiple times.
  }


  { TIBXScript }

  TIBXScript = class(TComponent)
  private
    FDatabase: TIBDatabase;
    FEcho: boolean;
    FIgnoreGrants: boolean;
    FOnErrorLog: TLogEvent;
    FOnProgressEvent: TOnProgressEvent;
    FOnSelectSQL: TOnSelectSQL;
    FStopOnFirstError: boolean;
    FTransaction: TIBTransaction;
    FInternalTransaction: TIBTransaction;
    FState: TSQLStates;
    FString: string;
    FISQL: TIBSQL;
    FLastSymbol: TSQLSymbol;
    FNested: integer;
    FLastChar: char;
    FSQLText: string;
    FHasBegin: boolean;
    FStack: array [0..16] of TSQLStates;
    FStackindex: integer;
    FGetParamValue: TGetParamValue;
    FOnOutputLog: TLogEvent;
    FTerminator: char;
    FAutoDDL: boolean;
    procedure Add2Log(const Msg: string; IsError: boolean=true);
    procedure AddToSQL(const Symbol: string);
    function AnalyseSQL(Lines: TStringList): boolean;
    procedure AnalyseLine(const Line: string);
    procedure DoCommit;
    procedure DoReconnect;
    procedure ExecSQL;
    function GetNextSymbol(C: char): TSQLSymbol;
    function GetSymbol(const Line: string; var index: integer): TSQLSymbol;
    function GetTransaction: TIBTransaction;
    procedure SetDatabase(AValue: TIBDatabase);
    procedure SetParamValue(SQLVar: TIBXSQLVAR);
    procedure SetState(AState: TSQLStates);
    procedure ClearStatement;
    function PopState: TSQLStates;
    function ProcessSetStatement(stmt: string): boolean;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
    function PerformUpdate(const SQLFile: string;  AutoDDL: boolean): boolean; overload;
    function PerformUpdate(const SQLStream: TStream;   AutoDDL: boolean): boolean; overload;
  published
    property Database: TIBDatabase read FDatabase write SetDatabase;
    property Echo: boolean read FEcho write FEcho default true;  {Echo Input to Log}
    property IgnoreGrants: boolean read FIgnoreGrants write FIgnoreGrants;
    property Transaction: TIBTransaction read FTransaction write FTransaction;
    property StopOnFirstError: boolean read FStopOnFirstError write FStopOnFirstError default true;
    property GetParamValue: TGetParamValue read FGetParamValue write FGetParamValue; {resolve parameterized queries}
    property OnOutputLog: TLogEvent read FOnOutputLog write FOnOutputLog; {Log handler}
    property OnErrorLog: TLogEvent read FOnErrorLog write FOnErrorLog;
    property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
    property OnSelectSQL: TOnSelectSQL read FOnSelectSQL write FOnSelectSQL; {Handle Select SQL Statements}
  end;

implementation

uses Sysutils, IB, RegExpr;

resourcestring
  sTerminatorUnknownState = 'Statement Terminator in unexpected state (%d)';
  sUnterminatedString = 'Unterminated string';
  sUnknownSymbol = 'Unknown Symbol %d';
  sNoSelectSQL = 'Select SQL Statements are not supported';
  sStackUnderflow = 'Stack Underflow';
  sInvalidAutoDDL = 'Invalid AUTODDL Statement - %s';
  sNoParamQueries =  'Parameterised Queries are not supported';
  sStackOverFlow = 'Stack Overflow';
  sResolveQueryParam =  'Resolving Query Parameter: %s';
  sNoCommit =  'Commit not allowed here';
  sNoReconnect = 'Reconnect not allowed here';

{ TIBXScript }

procedure TIBXScript.Add2Log(const Msg: string; IsError: boolean);
begin
  if IsError then
  begin
    if assigned(OnErrorLog) then OnErrorLog(self,Msg)
  end
  else
  if assigned(FOnOutputLog) then FOnOutputLog(self,Msg)
end;

procedure TIBXScript.AddToSQL(const Symbol: string);
begin
  FSQLText := FSQLText +  Symbol
end;

procedure TIBXScript.AnalyseLine(const Line: string);
var index: integer;
    Symbol: TSQLSymbol;
    NonSpace: boolean;
begin
  index := 1;
  NonSpace := false;
  while true do
  begin
    if FState = stError then
      raise Exception.Create('Entered Error State');
    Symbol := GetSymbol(Line,index);
    if not (Symbol in [sqSpace,sqEOL]) then
      NonSpace := true;
    case Symbol of
    sqSpace:
      if not (FState in [stInComment,stInCommentLine]) then
        AddToSQL(' ');

    sqTerminator:
      if not (FState in [stInComment,stInCommentLine]) then
        case FState of
        stInit: {ignore empty statement};

        stInSQL:
            ExecSQL;

       stInCommit:
            DoCommit;

       stInReconnect:
           DoReconnect;

       stNested, stInSingleQuotes, stInDoubleQuotes:
         AddToSQL(FTerminator);

       stInDeclaration:
         begin
           FState := PopState;
           AddToSQL(FTerminator);
         end;

       else
         raise Exception.CreateFmt(sTerminatorUnknownState,[FState]);
       end;

    sqSemiColon:
        begin
          if FState = stInDeclaration then
            FState := PopState;
          AddToSQL(';');
        end;

    sqAsterisk:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
       AddToSQL('*');
       if FState =  stInit then
          FState := stInSQL
      end;

    sqForwardSlash:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
       AddToSQL('/');
       if FState =  stInit then
          FState := stInSQL
      end;

    sqCommentStart:
      if not (FState in [stInComment,stInCommentLine]) then
        SetState(stInComment);

    sqCommentEnd:
      if FState = stInComment then
      begin
        AddToSQL('/* ' + Trim(FString) + ' */');
        FState := PopState
      end
      else
        FState := stError;

    sqCommentLine:
      if not (FState in [stInComment,stInCommentLine]) then
        SetState(stInCommentLine);

    sqSingleQuotes:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        case FState of
        stInSingleQuotes:
          FState := PopState;
        stInDoubleQuotes:
          {Ignore};
        else
          SetState(stInSingleQuotes)
        end;
        AddToSQL('''')
      end;

    sqDoubleQuotes:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        case FState of
        stInSingleQuotes:
          {Ignore};
        stInDoubleQuotes:
          FState := PopState;
        else
          SetState(stInDoubleQuotes)
        end;
        AddToSQL('"')
      end;

    sqEnd:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        AddToSQL(FString);
        case FState of
        stInSingleQuotes,
        stInDoubleQuotes:
          {Ignore};
        stNested:
          begin
            if FNested = 0 then
            begin
              PopState;
              FState := stInit;
              ExecSQL
            end
           else
              Dec(FNested)
          end;
          {Otherwise ignore}
        end
      end;

    sqBegin:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        FHasBegin := true;
        AddToSQL(FString);
        case FState of
        stInSingleQuotes,
        stInDoubleQuotes:
          {Ignore};
        stNested:
          Inc(FNested);

        stInSQL,
        stInit:
          SetState(stNested);
        end
      end;

    sqDeclare:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        AddToSQL(FString);
        if FState in [stInit,stInSQL] then
          SetState(stInDeclaration)
      end;

    sqCommit:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        if FState = stInit then
          FState := stInCommit
        else
          raise Exception.Create(sNoCommit)
      end;

    sqReconnect:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        if FState = stInit then
          FState := stInReconnect
        else
          raise Exception.Create(sNoReconnect)
      end;

    sqString:
      if not (FState in [stInComment,stInCommentLine]) then
      begin
        AddToSQL(FString);
        if FState = stInit then
          FState := stInSQL
      end;

    sqEOL:
      begin
        case FState of
        stInCommentLine:
        begin
          AddToSQL('/* ' + Trim(FString) + ' */');
          FState := PopState;
        end;
        stInDoubleQuotes,
        stInSingleQuotes:
          raise Exception.Create(sUnterminatedString);
        end;
        if NonSpace then AddToSQL(#13#10);
        Exit;
      end;
    else
      raise Exception.CreateFmt(sUnknownSymbol,[Symbol]);
    end
  end
end;

function TIBXScript.AnalyseSQL(Lines: TStringList): boolean;
var I: integer;
begin
  Result := true;
  ClearStatement;
  FLastSymbol := sqNone;
  for I := 0 to Lines.Count - 1 do
  begin
    if Echo then Add2Log(Lines[I],false);
    if assigned(OnProgressEvent) then
      OnProgressEvent(self,false,1);
    try
      AnalyseLine(Lines[I]);
    except on E:Exception do
      begin
        Add2Log(E.Message);
        Result := false;
        if StopOnFirstError then Exit;
        ClearStatement;
        FLastSymbol := sqNone;
      end
    end;
  end;
  if FState <> stInit then
    AnalyseLine(';');
  Result := (FStackIndex = 0) and (FState = stInit)
end;

constructor TIBXScript.Create(aOwner: TComponent);
begin
  inherited;
  FStopOnFirstError := true;
  FEcho := true;
  FState := stInit;
  FISQL := TIBSQL.Create(self);
  FISQL.ParamCheck := true;
  FInternalTransaction := TIBTransaction.Create(self);
  FInternalTransaction.Params.Clear;
  FInternalTransaction.Params.Add('concurrency');
  FInternalTransaction.Params.Add('wait');
  ClearStatement;
end;

destructor TIBXScript.Destroy;
begin
  if FISQL <> nil then FISQL.Free;
  if FInternalTransaction <> nil then FInternalTransaction.Free;
  inherited;
end;

procedure TIBXScript.DoCommit;
begin
  with GetTransaction do
    if InTransaction then Commit;
  if not GetTransaction.InTransaction then
    GetTransaction.StartTransaction;
  ClearStatement;
end;

procedure TIBXScript.DoReconnect;
begin
  with GetTransaction do
    if InTransaction then Commit;
  Database.Connected := false;
  Database.Connected := true;
  if not GetTransaction.InTransaction then
    GetTransaction.StartTransaction;
  ClearStatement;
end;

procedure TIBXScript.ExecSQL;
var DDL: boolean;
    I: integer;
begin
 if FSQLText <> '' then
 begin
   if ProcessSetStatement(FSQLText) then {Handle Set Statement}
   begin
     ClearStatement;
     Exit;
   end;

   FISQL.SQL.Text := FSQLText;
   FISQL.Transaction := GetTransaction;
   with FISQL.Transaction do
     if not InTransaction then StartTransaction;
   FISQL.ParamCheck := not FHasBegin; {Probably PSQL}
   FISQL.Prepare;
   if FISQL.SQLType in [SQLInsert, SQLUpdate, SQLDelete] then
   begin
     {Interpret parameters}
     for I := 0 to FISQL.Params.Count - 1 do
       SetParamValue(FISQL.Params[I]);
   end;

   if FISQL.SQLType = SQLSelect then
   begin
     if assigned(OnSelectSQL) then
       OnSelectSQL(self,FSQLText)
     else
       raise Exception.Create(sNoSelectSQL);
   end
   else
   begin
     DDL := FISQL.SQLType = SQLDDL;
     if not DDL or not FIgnoreGrants or (Pos('GRANT',AnsiUpperCase(Trim(FSQLText))) <> 1) then
       FISQL.ExecQuery;
     if FAutoDDL and DDL then
       FISQL.Transaction.Commit;
     FISQL.Close;
   end;
   FISQL.SQL.Clear;
   ClearStatement;
 end
end;


function TIBXScript.GetNextSymbol(C: char): TSQLSymbol;
begin
    if C = FTerminator then
      Result := sqTerminator
    else
    case C of
    ' ',#9:
      Result := sqSpace;
    ';':
      Result := sqSemiColon;
    '"':
      Result := sqDoubleQuotes;
    '''':
      Result := sqSingleQuotes;
    '/':
      Result := sqForwardSlash;
    '*':
      Result := sqAsterisk;
    else
      begin
        Result := sqString;
        FLastChar := C
      end
    end;
end;

function TIBXScript.GetSymbol(const Line: string; var index: integer): TSQLSymbol;
begin
  Result := sqNone;
  if FLastSymbol <> sqNone then
  begin
    Result := FLastSymbol;
    if Result = sqString then
      FString := FLastChar;
    FLastSymbol := sqNone
  end;

  while (index <= Length(Line)) and (FLastSymbol = sqNone) do
  begin
    FLastSymbol := GetNextSymbol(Line[index]);
    {combine if possible}
    case Result of
    sqNone:
      begin
        Result := FLastSymbol;
        if FLastSymbol = sqString then
          FString := FLastChar;
        FLastSymbol := sqNone
      end;

    sqForwardSlash:
      if FLastSymbol = sqAsterisk then
      begin
        Result := sqCommentStart;
        FLastSymbol := sqNone
      end
      else
      if FLastSymbol = sqForwardSlash then
      begin
        Result := sqCommentLine;
        FLastSymbol := sqNone
      end;

    sqAsterisk:
      if FLastSymbol = sqForwardSlash then
      begin
        Result := sqCommentEnd;
        FLastSymbol := sqNone
      end;

    sqString:
      if FLastSymbol = sqString then
      begin
        FString := FString + FLastChar;
        FLastSymbol := sqNone
      end;
    end;
    Inc(index)
  end;

  if (index > Length(Line)) then
    if Result = sqNone then
      Result := sqEOL
    else
    if (FLastSymbol = sqNone) and (Result <> sqEOL) then
      FLastSymbol := sqEOL;

  if Result = sqString then
  begin
    if FString <> '' then
      if CompareText(FString,'begin') = 0 then
        Result := sqBegin
      else
      if CompareText(FString,'end') = 0 then
        Result := sqEnd
      else
      if CompareText(FString,'declare') = 0 then
        Result := sqDeclare
      else
      if CompareText(FString,'commit') = 0 then
        Result := sqCommit
      else
      if CompareText(FString,'reconnect') = 0 then
        Result := sqReconnect;
  end
end;

function TIBXScript.GetTransaction: TIBTransaction;
begin
  if FTransaction = nil then
    Result := FInternalTransaction
  else
    Result := FTransaction;
end;

procedure TIBXScript.SetDatabase(AValue: TIBDatabase);
begin
  if FDatabase = AValue then Exit;
  FDatabase := AValue;
  FISQL.Database := AValue;
  FInternalTransaction.DefaultDatabase := AValue;
end;

function TIBXScript.PerformUpdate(const SQLFile: string;
                                     AutoDDL: boolean): boolean;
var F: TFileStream;
begin
  F := TFileStream.Create(SQLFile,fmOpenRead or fmShareDenyNone);
  try
    Result := PerformUpdate(F,AutoDDL)
  finally
    F.Free
  end;
end;

function TIBXScript.PerformUpdate(const SQLStream: TStream; AutoDDL: boolean): boolean;
var Lines: TStringList;
    FNotConnected: boolean;
begin
  FTerminator := ';';
  FAutoDDL := AutoDDL;
  FNotConnected := not Database.Connected;
  Database.Connected := true;
  try
    Lines := TStringList.Create;
    Lines.LoadFromStream(SQLStream);
    try
      if assigned(OnProgressEvent) then
        OnProgressEvent(self,true,Lines.Count);

      Result := AnalyseSQL(Lines)
    finally
      Lines.Free
    end;
  except on E:Exception do
    begin
      Add2Log(E.Message);
      with GetTransaction do
        if InTransaction then Rollback;
      Result := false
    end
  end;
  with GetTransaction do
    if InTransaction then Commit;
  if FNotConnected then
    Database.Connected := false;
end;

function TIBXScript.PopState: TSQLStates;
begin
  if FStackIndex = 0 then
    raise Exception.Create(sStackUnderflow);
  Dec(FStackIndex);
  Result := FStack[FStackIndex]
end;

function TIBXScript.ProcessSetStatement(stmt: string): boolean;
var  RegexObj: TRegExpr;
begin
  Result := false;
  RegexObj := TRegExpr.Create;
  try
    {Process Set Term}
    RegexObj.Expression := 'SET +TERM +(.) *(\' + FTerminator + '|)';
    if RegexObj.Exec(AnsiUpperCase(stmt)) then
    begin
       FTerminator := RegexObj.Match[1][1];
       Result := true;
       Exit;
    end;

    {Process AutoDDL}
    RegexObj.Expression := 'SET +AUTODDL +([a-zA-Z]+) *(\' + FTerminator + '|)';
    if RegexObj.Exec(AnsiUpperCase(stmt)) then
    begin
      if  AnsiUpperCase(RegexObj.Match[1]) = 'ON' then
        FAutoDDL := true
      else
      if  AnsiUpperCase(RegexObj.Match[1]) = 'OFF' then
        FAutoDDL := false
      else
        raise Exception.CreateFmt(sInvalidAutoDDL, [RegexObj.Match[0]]);

      Result := true;
    end;
  finally
    RegexObj.Free;
  end;
end;


procedure TIBXScript.SetParamValue(SQLVar: TIBXSQLVAR);
var BlobID: TISC_QUAD;
begin
  if assigned(FGetParamValue) and (SQLVar.SQLType = SQL_BLOB) then
  begin
    Add2Log(Format(sResolveQueryParam,[SQLVar.Name]));
    GetParamValue(self,SQLVar.Name,BlobID);
    if (BlobID.gds_quad_high = 0) and (BlobID.gds_quad_low = 0) then
      SQLVar.Clear
    else
      SQLVar.AsQuad := BlobID
  end
  else
    raise Exception.Create(sNoParamQueries);
end;

procedure TIBXScript.SetState(AState: TSQLStates);
begin
  if FStackIndex > 16 then
    raise Exception.Create(sStackOverFlow);
  FStack[FStackIndex] := FState;
  Inc(FStackIndex);
  FState := AState
end;

procedure TIBXScript.ClearStatement;
begin
  FSQLText := '';
  FState := stInit;
  FHasBegin := false;
  FLastChar := ' ';
  FLastSymbol := sqNone;
end;

end.

Revision:	37
Committed:	Mon Feb 15 14:44:25 2016 UTC (8 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	21025 byte(s)
Log Message:	Committing updates for Release R1-4-0
#	User	Rev	Content
1	tony	37	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2014 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26			unit ibxscript;
27
28			{$mode objfpc}{$H+}
29
30			interface
31
32			uses Classes, IBDatabase, IBSQL, IBHeader;
33
34			type
35			TSQLSymbol = (sqNone,sqSpace,sqSemiColon,sqSingleQuotes,sqDoubleQuotes,
36			sqEnd,sqBegin,sqCommit,sqRollback,sqString,sqCommentStart,
37			sqCommentEnd,sqCommentLine,sqAsterisk,sqForwardSlash,
38			sqDeclare,sqEOL,sqTerminator, sqReconnect);
39
40			TSQLStates = (stInit, stError, stInSQL, stNested,stInSingleQuotes,
41			stInDoubleQuotes, stInComment, stInCommentLine,
42			stInDeclaration, stInCommit, stInReconnect);
43
44			TGetParamValue = procedure(Sender: TObject; ParamName: string; var BlobID: TISC_QUAD) of object;
45			TLogEvent = procedure(Sender: TObject; Msg: string) of Object;
46			TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
47			TOnSelectSQL = procedure (Sender: TObject; SQLText: string) of object;
48
49			{
50			TIBXScript: runs an SQL script in the specified file or stream. The text is parsed
51			into SQL statements which are executed in turn. The intention is to be ISQL
52			compatible but with extensions:
53
54			* SET TERM and Set AutoDDL are both supported
55
56			* New Command: RECONNECT. Performs a commit followed by disconnecting and
57			reconnecting to the database.
58
59			* Procedure Bodies (BEGIN .. END blocks) are self-delimiting and do not need
60			an extra terminator. If a terminator is present, this is treated as an
61			empty statement. The result is ISQL compatible, but does not require the
62			use of SET TERM.
63
64			* DML statements may have arguments in IBX format (e.g UPDATE MYTABLE Set data = :mydata).
65			Arguments are valid only for BLOB columns and are resolved using the GetParamValue
66			event. This returns the blobid to be used. A typical use of the event is to
67			read binary data from a file, save it in a blob stream and return the blob id.
68
69			Select SQL statements are not directly supported but can be handled by an external
70			handler (OnSelectSQL event). If the handler is not present then an exception
71			is raised if a Select SQL statement is found.
72
73			Properties:
74
75			* Database: Link to TIBDatabase component
76			* Transaction: Link to Transaction. Defaults to internaltransaction (concurrency, wait)
77			* Echo: boolean. When true, all SQL statements are echoed to log
78			* StopOnFirstError: boolean. When true the script engine terminates on the first
79			SQL Error.
80			* IgnoreGrants: When true, grant statements are silently discarded. This can be
81			useful when applying a script using the Embedded Server.
82
83
84			Events:
85
86			* GetParamValue: called when an SQL parameter is found (in PSQL :name format).
87			This is only called for blob fields. Handler should return the BlobID to be
88			used as the parameter value. If not present an exception is raised when a
89			parameter is found.
90			* OnOutputLog: Called to write SQL Statements to the log (stdout)
91			* OnErrorLog: Called to write all other messages to the log (stderr)
92			* OnProgressEvent: Progress bar support. If Reset is true the value is maximum
93			value of progress bar. Otherwise called to step progress bar.
94			* OnSelectSQL: handler for select SQL statements. If not present, select SQL
95			statements result in an exception.
96
97			The PerformUpdate function is used to execute an SQL Script and may be called
98			multiple times.
99			}
100
101
102			{ TIBXScript }
103
104			TIBXScript = class(TComponent)
105			private
106			FDatabase: TIBDatabase;
107			FEcho: boolean;
108			FIgnoreGrants: boolean;
109			FOnErrorLog: TLogEvent;
110			FOnProgressEvent: TOnProgressEvent;
111			FOnSelectSQL: TOnSelectSQL;
112			FStopOnFirstError: boolean;
113			FTransaction: TIBTransaction;
114			FInternalTransaction: TIBTransaction;
115			FState: TSQLStates;
116			FString: string;
117			FISQL: TIBSQL;
118			FLastSymbol: TSQLSymbol;
119			FNested: integer;
120			FLastChar: char;
121			FSQLText: string;
122			FHasBegin: boolean;
123			FStack: array [0..16] of TSQLStates;
124			FStackindex: integer;
125			FGetParamValue: TGetParamValue;
126			FOnOutputLog: TLogEvent;
127			FTerminator: char;
128			FAutoDDL: boolean;
129			procedure Add2Log(const Msg: string; IsError: boolean=true);
130			procedure AddToSQL(const Symbol: string);
131			function AnalyseSQL(Lines: TStringList): boolean;
132			procedure AnalyseLine(const Line: string);
133			procedure DoCommit;
134			procedure DoReconnect;
135			procedure ExecSQL;
136			function GetNextSymbol(C: char): TSQLSymbol;
137			function GetSymbol(const Line: string; var index: integer): TSQLSymbol;
138			function GetTransaction: TIBTransaction;
139			procedure SetDatabase(AValue: TIBDatabase);
140			procedure SetParamValue(SQLVar: TIBXSQLVAR);
141			procedure SetState(AState: TSQLStates);
142			procedure ClearStatement;
143			function PopState: TSQLStates;
144			function ProcessSetStatement(stmt: string): boolean;
145			public
146			constructor Create(aOwner: TComponent); override;
147			destructor Destroy; override;
148			function PerformUpdate(const SQLFile: string; AutoDDL: boolean): boolean; overload;
149			function PerformUpdate(const SQLStream: TStream; AutoDDL: boolean): boolean; overload;
150			published
151			property Database: TIBDatabase read FDatabase write SetDatabase;
152			property Echo: boolean read FEcho write FEcho default true; {Echo Input to Log}
153			property IgnoreGrants: boolean read FIgnoreGrants write FIgnoreGrants;
154			property Transaction: TIBTransaction read FTransaction write FTransaction;
155			property StopOnFirstError: boolean read FStopOnFirstError write FStopOnFirstError default true;
156			property GetParamValue: TGetParamValue read FGetParamValue write FGetParamValue; {resolve parameterized queries}
157			property OnOutputLog: TLogEvent read FOnOutputLog write FOnOutputLog; {Log handler}
158			property OnErrorLog: TLogEvent read FOnErrorLog write FOnErrorLog;
159			property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
160			property OnSelectSQL: TOnSelectSQL read FOnSelectSQL write FOnSelectSQL; {Handle Select SQL Statements}
161			end;
162
163			implementation
164
165			uses Sysutils, IB, RegExpr;
166
167			resourcestring
168			sTerminatorUnknownState = 'Statement Terminator in unexpected state (%d)';
169			sUnterminatedString = 'Unterminated string';
170			sUnknownSymbol = 'Unknown Symbol %d';
171			sNoSelectSQL = 'Select SQL Statements are not supported';
172			sStackUnderflow = 'Stack Underflow';
173			sInvalidAutoDDL = 'Invalid AUTODDL Statement - %s';
174			sNoParamQueries = 'Parameterised Queries are not supported';
175			sStackOverFlow = 'Stack Overflow';
176			sResolveQueryParam = 'Resolving Query Parameter: %s';
177			sNoCommit = 'Commit not allowed here';
178			sNoReconnect = 'Reconnect not allowed here';
179
180			{ TIBXScript }
181
182			procedure TIBXScript.Add2Log(const Msg: string; IsError: boolean);
183			begin
184			if IsError then
185			begin
186			if assigned(OnErrorLog) then OnErrorLog(self,Msg)
187			end
188			else
189			if assigned(FOnOutputLog) then FOnOutputLog(self,Msg)
190			end;
191
192			procedure TIBXScript.AddToSQL(const Symbol: string);
193			begin
194			FSQLText := FSQLText + Symbol
195			end;
196
197			procedure TIBXScript.AnalyseLine(const Line: string);
198			var index: integer;
199			Symbol: TSQLSymbol;
200			NonSpace: boolean;
201			begin
202			index := 1;
203			NonSpace := false;
204			while true do
205			begin
206			if FState = stError then
207			raise Exception.Create('Entered Error State');
208			Symbol := GetSymbol(Line,index);
209			if not (Symbol in [sqSpace,sqEOL]) then
210			NonSpace := true;
211			case Symbol of
212			sqSpace:
213			if not (FState in [stInComment,stInCommentLine]) then
214			AddToSQL(' ');
215
216			sqTerminator:
217			if not (FState in [stInComment,stInCommentLine]) then
218			case FState of
219			stInit: {ignore empty statement};
220
221			stInSQL:
222			ExecSQL;
223
224			stInCommit:
225			DoCommit;
226
227			stInReconnect:
228			DoReconnect;
229
230			stNested, stInSingleQuotes, stInDoubleQuotes:
231			AddToSQL(FTerminator);
232
233			stInDeclaration:
234			begin
235			FState := PopState;
236			AddToSQL(FTerminator);
237			end;
238
239			else
240			raise Exception.CreateFmt(sTerminatorUnknownState,[FState]);
241			end;
242
243			sqSemiColon:
244			begin
245			if FState = stInDeclaration then
246			FState := PopState;
247			AddToSQL(';');
248			end;
249
250			sqAsterisk:
251			if not (FState in [stInComment,stInCommentLine]) then
252			begin
253			AddToSQL('*');
254			if FState = stInit then
255			FState := stInSQL
256			end;
257
258			sqForwardSlash:
259			if not (FState in [stInComment,stInCommentLine]) then
260			begin
261			AddToSQL('/');
262			if FState = stInit then
263			FState := stInSQL
264			end;
265
266			sqCommentStart:
267			if not (FState in [stInComment,stInCommentLine]) then
268			SetState(stInComment);
269
270			sqCommentEnd:
271			if FState = stInComment then
272			begin
273			AddToSQL('/* ' + Trim(FString) + ' */');
274			FState := PopState
275			end
276			else
277			FState := stError;
278
279			sqCommentLine:
280			if not (FState in [stInComment,stInCommentLine]) then
281			SetState(stInCommentLine);
282
283			sqSingleQuotes:
284			if not (FState in [stInComment,stInCommentLine]) then
285			begin
286			case FState of
287			stInSingleQuotes:
288			FState := PopState;
289			stInDoubleQuotes:
290			{Ignore};
291			else
292			SetState(stInSingleQuotes)
293			end;
294			AddToSQL('''')
295			end;
296
297			sqDoubleQuotes:
298			if not (FState in [stInComment,stInCommentLine]) then
299			begin
300			case FState of
301			stInSingleQuotes:
302			{Ignore};
303			stInDoubleQuotes:
304			FState := PopState;
305			else
306			SetState(stInDoubleQuotes)
307			end;
308			AddToSQL('"')
309			end;
310
311			sqEnd:
312			if not (FState in [stInComment,stInCommentLine]) then
313			begin
314			AddToSQL(FString);
315			case FState of
316			stInSingleQuotes,
317			stInDoubleQuotes:
318			{Ignore};
319			stNested:
320			begin
321			if FNested = 0 then
322			begin
323			PopState;
324			FState := stInit;
325			ExecSQL
326			end
327			else
328			Dec(FNested)
329			end;
330			{Otherwise ignore}
331			end
332			end;
333
334			sqBegin:
335			if not (FState in [stInComment,stInCommentLine]) then
336			begin
337			FHasBegin := true;
338			AddToSQL(FString);
339			case FState of
340			stInSingleQuotes,
341			stInDoubleQuotes:
342			{Ignore};
343			stNested:
344			Inc(FNested);
345
346			stInSQL,
347			stInit:
348			SetState(stNested);
349			end
350			end;
351
352			sqDeclare:
353			if not (FState in [stInComment,stInCommentLine]) then
354			begin
355			AddToSQL(FString);
356			if FState in [stInit,stInSQL] then
357			SetState(stInDeclaration)
358			end;
359
360			sqCommit:
361			if not (FState in [stInComment,stInCommentLine]) then
362			begin
363			if FState = stInit then
364			FState := stInCommit
365			else
366			raise Exception.Create(sNoCommit)
367			end;
368
369			sqReconnect:
370			if not (FState in [stInComment,stInCommentLine]) then
371			begin
372			if FState = stInit then
373			FState := stInReconnect
374			else
375			raise Exception.Create(sNoReconnect)
376			end;
377
378			sqString:
379			if not (FState in [stInComment,stInCommentLine]) then
380			begin
381			AddToSQL(FString);
382			if FState = stInit then
383			FState := stInSQL
384			end;
385
386			sqEOL:
387			begin
388			case FState of
389			stInCommentLine:
390			begin
391			AddToSQL('/* ' + Trim(FString) + ' */');
392			FState := PopState;
393			end;
394			stInDoubleQuotes,
395			stInSingleQuotes:
396			raise Exception.Create(sUnterminatedString);
397			end;
398			if NonSpace then AddToSQL(#13#10);
399			Exit;
400			end;
401			else
402			raise Exception.CreateFmt(sUnknownSymbol,[Symbol]);
403			end
404			end
405			end;
406
407			function TIBXScript.AnalyseSQL(Lines: TStringList): boolean;
408			var I: integer;
409			begin
410			Result := true;
411			ClearStatement;
412			FLastSymbol := sqNone;
413			for I := 0 to Lines.Count - 1 do
414			begin
415			if Echo then Add2Log(Lines[I],false);
416			if assigned(OnProgressEvent) then
417			OnProgressEvent(self,false,1);
418			try
419			AnalyseLine(Lines[I]);
420			except on E:Exception do
421			begin
422			Add2Log(E.Message);
423			Result := false;
424			if StopOnFirstError then Exit;
425			ClearStatement;
426			FLastSymbol := sqNone;
427			end
428			end;
429			end;
430			if FState <> stInit then
431			AnalyseLine(';');
432			Result := (FStackIndex = 0) and (FState = stInit)
433			end;
434
435			constructor TIBXScript.Create(aOwner: TComponent);
436			begin
437			inherited;
438			FStopOnFirstError := true;
439			FEcho := true;
440			FState := stInit;
441			FISQL := TIBSQL.Create(self);
442			FISQL.ParamCheck := true;
443			FInternalTransaction := TIBTransaction.Create(self);
444			FInternalTransaction.Params.Clear;
445			FInternalTransaction.Params.Add('concurrency');
446			FInternalTransaction.Params.Add('wait');
447			ClearStatement;
448			end;
449
450			destructor TIBXScript.Destroy;
451			begin
452			if FISQL <> nil then FISQL.Free;
453			if FInternalTransaction <> nil then FInternalTransaction.Free;
454			inherited;
455			end;
456
457			procedure TIBXScript.DoCommit;
458			begin
459			with GetTransaction do
460			if InTransaction then Commit;
461			if not GetTransaction.InTransaction then
462			GetTransaction.StartTransaction;
463			ClearStatement;
464			end;
465
466			procedure TIBXScript.DoReconnect;
467			begin
468			with GetTransaction do
469			if InTransaction then Commit;
470			Database.Connected := false;
471			Database.Connected := true;
472			if not GetTransaction.InTransaction then
473			GetTransaction.StartTransaction;
474			ClearStatement;
475			end;
476
477			procedure TIBXScript.ExecSQL;
478			var DDL: boolean;
479			I: integer;
480			begin
481			if FSQLText <> '' then
482			begin
483			if ProcessSetStatement(FSQLText) then {Handle Set Statement}
484			begin
485			ClearStatement;
486			Exit;
487			end;
488
489			FISQL.SQL.Text := FSQLText;
490			FISQL.Transaction := GetTransaction;
491			with FISQL.Transaction do
492			if not InTransaction then StartTransaction;
493			FISQL.ParamCheck := not FHasBegin; {Probably PSQL}
494			FISQL.Prepare;
495			if FISQL.SQLType in [SQLInsert, SQLUpdate, SQLDelete] then
496			begin
497			{Interpret parameters}
498			for I := 0 to FISQL.Params.Count - 1 do
499			SetParamValue(FISQL.Params[I]);
500			end;
501
502			if FISQL.SQLType = SQLSelect then
503			begin
504			if assigned(OnSelectSQL) then
505			OnSelectSQL(self,FSQLText)
506			else
507			raise Exception.Create(sNoSelectSQL);
508			end
509			else
510			begin
511			DDL := FISQL.SQLType = SQLDDL;
512			if not DDL or not FIgnoreGrants or (Pos('GRANT',AnsiUpperCase(Trim(FSQLText))) <> 1) then
513			FISQL.ExecQuery;
514			if FAutoDDL and DDL then
515			FISQL.Transaction.Commit;
516			FISQL.Close;
517			end;
518			FISQL.SQL.Clear;
519			ClearStatement;
520			end
521			end;
522
523
524
525			function TIBXScript.GetNextSymbol(C: char): TSQLSymbol;
526			begin
527			if C = FTerminator then
528			Result := sqTerminator
529			else
530			case C of
531			' ',#9:
532			Result := sqSpace;
533			';':
534			Result := sqSemiColon;
535			'"':
536			Result := sqDoubleQuotes;
537			'''':
538			Result := sqSingleQuotes;
539			'/':
540			Result := sqForwardSlash;
541			'*':
542			Result := sqAsterisk;
543			else
544			begin
545			Result := sqString;
546			FLastChar := C
547			end
548			end;
549			end;
550
551			function TIBXScript.GetSymbol(const Line: string; var index: integer): TSQLSymbol;
552			begin
553			Result := sqNone;
554			if FLastSymbol <> sqNone then
555			begin
556			Result := FLastSymbol;
557			if Result = sqString then
558			FString := FLastChar;
559			FLastSymbol := sqNone
560			end;
561
562			while (index <= Length(Line)) and (FLastSymbol = sqNone) do
563			begin
564			FLastSymbol := GetNextSymbol(Line[index]);
565			{combine if possible}
566			case Result of
567			sqNone:
568			begin
569			Result := FLastSymbol;
570			if FLastSymbol = sqString then
571			FString := FLastChar;
572			FLastSymbol := sqNone
573			end;
574
575			sqForwardSlash:
576			if FLastSymbol = sqAsterisk then
577			begin
578			Result := sqCommentStart;
579			FLastSymbol := sqNone
580			end
581			else
582			if FLastSymbol = sqForwardSlash then
583			begin
584			Result := sqCommentLine;
585			FLastSymbol := sqNone
586			end;
587
588			sqAsterisk:
589			if FLastSymbol = sqForwardSlash then
590			begin
591			Result := sqCommentEnd;
592			FLastSymbol := sqNone
593			end;
594
595			sqString:
596			if FLastSymbol = sqString then
597			begin
598			FString := FString + FLastChar;
599			FLastSymbol := sqNone
600			end;
601			end;
602			Inc(index)
603			end;
604
605			if (index > Length(Line)) then
606			if Result = sqNone then
607			Result := sqEOL
608			else
609			if (FLastSymbol = sqNone) and (Result <> sqEOL) then
610			FLastSymbol := sqEOL;
611
612			if Result = sqString then
613			begin
614			if FString <> '' then
615			if CompareText(FString,'begin') = 0 then
616			Result := sqBegin
617			else
618			if CompareText(FString,'end') = 0 then
619			Result := sqEnd
620			else
621			if CompareText(FString,'declare') = 0 then
622			Result := sqDeclare
623			else
624			if CompareText(FString,'commit') = 0 then
625			Result := sqCommit
626			else
627			if CompareText(FString,'reconnect') = 0 then
628			Result := sqReconnect;
629			end
630			end;
631
632			function TIBXScript.GetTransaction: TIBTransaction;
633			begin
634			if FTransaction = nil then
635			Result := FInternalTransaction
636			else
637			Result := FTransaction;
638			end;
639
640			procedure TIBXScript.SetDatabase(AValue: TIBDatabase);
641			begin
642			if FDatabase = AValue then Exit;
643			FDatabase := AValue;
644			FISQL.Database := AValue;
645			FInternalTransaction.DefaultDatabase := AValue;
646			end;
647
648			function TIBXScript.PerformUpdate(const SQLFile: string;
649			AutoDDL: boolean): boolean;
650			var F: TFileStream;
651			begin
652			F := TFileStream.Create(SQLFile,fmOpenRead or fmShareDenyNone);
653			try
654			Result := PerformUpdate(F,AutoDDL)
655			finally
656			F.Free
657			end;
658			end;
659
660			function TIBXScript.PerformUpdate(const SQLStream: TStream; AutoDDL: boolean): boolean;
661			var Lines: TStringList;
662			FNotConnected: boolean;
663			begin
664			FTerminator := ';';
665			FAutoDDL := AutoDDL;
666			FNotConnected := not Database.Connected;
667			Database.Connected := true;
668			try
669			Lines := TStringList.Create;
670			Lines.LoadFromStream(SQLStream);
671			try
672			if assigned(OnProgressEvent) then
673			OnProgressEvent(self,true,Lines.Count);
674
675			Result := AnalyseSQL(Lines)
676			finally
677			Lines.Free
678			end;
679			except on E:Exception do
680			begin
681			Add2Log(E.Message);
682			with GetTransaction do
683			if InTransaction then Rollback;
684			Result := false
685			end
686			end;
687			with GetTransaction do
688			if InTransaction then Commit;
689			if FNotConnected then
690			Database.Connected := false;
691			end;
692
693			function TIBXScript.PopState: TSQLStates;
694			begin
695			if FStackIndex = 0 then
696			raise Exception.Create(sStackUnderflow);
697			Dec(FStackIndex);
698			Result := FStack[FStackIndex]
699			end;
700
701			function TIBXScript.ProcessSetStatement(stmt: string): boolean;
702			var RegexObj: TRegExpr;
703			begin
704			Result := false;
705			RegexObj := TRegExpr.Create;
706			try
707			{Process Set Term}
708			RegexObj.Expression := 'SET +TERM +(.) *(\' + FTerminator + '\|)';
709			if RegexObj.Exec(AnsiUpperCase(stmt)) then
710			begin
711			FTerminator := RegexObj.Match[1][1];
712			Result := true;
713			Exit;
714			end;
715
716			{Process AutoDDL}
717			RegexObj.Expression := 'SET +AUTODDL +([a-zA-Z]+) *(\' + FTerminator + '\|)';
718			if RegexObj.Exec(AnsiUpperCase(stmt)) then
719			begin
720			if AnsiUpperCase(RegexObj.Match[1]) = 'ON' then
721			FAutoDDL := true
722			else
723			if AnsiUpperCase(RegexObj.Match[1]) = 'OFF' then
724			FAutoDDL := false
725			else
726			raise Exception.CreateFmt(sInvalidAutoDDL, [RegexObj.Match[0]]);
727
728			Result := true;
729			end;
730			finally
731			RegexObj.Free;
732			end;
733			end;
734
735
736			procedure TIBXScript.SetParamValue(SQLVar: TIBXSQLVAR);
737			var BlobID: TISC_QUAD;
738			begin
739			if assigned(FGetParamValue) and (SQLVar.SQLType = SQL_BLOB) then
740			begin
741			Add2Log(Format(sResolveQueryParam,[SQLVar.Name]));
742			GetParamValue(self,SQLVar.Name,BlobID);
743			if (BlobID.gds_quad_high = 0) and (BlobID.gds_quad_low = 0) then
744			SQLVar.Clear
745			else
746			SQLVar.AsQuad := BlobID
747			end
748			else
749			raise Exception.Create(sNoParamQueries);
750			end;
751
752			procedure TIBXScript.SetState(AState: TSQLStates);
753			begin
754			if FStackIndex > 16 then
755			raise Exception.Create(sStackOverFlow);
756			FStack[FStackIndex] := FState;
757			Inc(FStackIndex);
758			FState := AState
759			end;
760
761			procedure TIBXScript.ClearStatement;
762			begin
763			FSQLText := '';
764			FState := stInit;
765			FHasBegin := false;
766			FLastChar := ' ';
767			FLastSymbol := sqNone;
768			end;
769
770			end.
771