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+}

{$IF FPC_FULLVERSION >= 20700 }
{$codepage UTF8}
{$ENDIF}

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