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

{$codepage UTF8}

interface

uses Classes, IBDatabase,  IBSQL, IB;

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

  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;
    FInCase: 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: ISQLParam);
    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, 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
              FState := PopState;
              if not FInCase then
              begin
                FState := stInit;
                ExecSQL
              end
              else
                FInCase := false;
            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;

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

      stInSQL,
      stInit:
        begin
          FInCase := true;
          SetState(stNested);
        end;
      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.SQLStatementType in [SQLInsert, SQLUpdate, SQLDelete] then
   begin
     {Interpret parameters}
     for I := 0 to FISQL.Params.Count - 1 do
       SetParamValue(FISQL.Params[I]);
   end;

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