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
          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:	39
Committed:	Tue May 17 08:14:52 2016 UTC (8 years, 6 months ago) by tony
Content type:	text/x-pascal
File size:	21084 byte(s)
Log Message:	Committing updates for Release R1-4-1
#	User	Rev	Content
1	tony	37	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18			* The Original Code is (C) 2014 Tony Whyman, MWA Software
19			* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26			unit ibxscript;
27
28			{$mode objfpc}{$H+}
29
30	tony	39	{$IF FPC_FULLVERSION >= 20700 }
31			{$codepage UTF8}
32			{$ENDIF}
33
34	tony	37	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			raise Exception.Create(sNoCommit)
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