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, 2 months ago) by tony
Content type:	text/x-pascal
File size:	21025 byte(s)
Log Message:	Committing updates for Release R1-4-0
#	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	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