PageRenderTime 42ms CodeModel.GetById 18ms app.highlight 11ms RepoModel.GetById 2ms app.codeStats 0ms

/Gedemin/IBX/IBScript.pas

http://gedemin.googlecode.com/
Pascal | 1064 lines | 930 code | 81 blank | 53 comment | 106 complexity | 2a634c357d0bfcf4c6f799d397dfa106 MD5 | raw file
   1{*************************************************************}
   2{                                                             }
   3{       Borland Delphi Visual Component Library               }
   4{       InterBase Express core components                     }
   5{                                                             }
   6{       Copyright (c) 2001 Jeff Overcash                      }
   7{                                                             }
   8{                                                             }
   9{*************************************************************}
  10
  11unit IBScript;
  12
  13interface
  14
  15uses
  16  SysUtils, Classes, IBDatabase, IBCustomDataset, IBSQL, IBDatabaseInfo;
  17
  18type
  19
  20  TIBScript = class;
  21
  22  TIBParseKind = (stmtDDL, stmtDML, stmtSET, stmtCONNECT, stmtDrop,
  23    stmtCREATE, stmtINPUT, stmtUNK, stmtEMPTY,
  24    stmtTERM, stmtERR, stmtCOMMIT, stmtROLLBACK);
  25
  26  TIBSQLParseError = procedure(Sender: TObject; Error: string; SQLText: string;
  27    LineIndex: Integer) of object;
  28  TIBSQLExecuteError = procedure(Sender: TObject; Error: string; SQLText:
  29    string;
  30    LineIndex: Integer; var Ignore: Boolean) of object;
  31  TIBSQLParseStmt = procedure(Sender: TObject; AKind: TIBParseKind; SQLText:
  32    string) of object;
  33  TIBScriptParamCheck = procedure(Sender: TIBScript; var Pause: Boolean) of
  34    object;
  35
  36  TIBSQLParser = class(TComponent)
  37  private
  38    FOnError: TIBSQLParseError;
  39    FOnParse: TIBSQLParseStmt;
  40    FScript, FInput: TStrings;
  41    FTerminator: string;
  42    FPaused: Boolean;
  43    FFinished: Boolean;
  44    procedure SetScript(const Value: TStrings);
  45    procedure SetPaused(const Value: Boolean);
  46    { Private declarations }
  47  private
  48    FTokens: TStrings;
  49    FWork: string;
  50    ScriptIndex, LineIndex, ImportIndex: Integer;
  51    InInput: Boolean;
  52
  53    //Get Tokens plus return the actual SQL to execute
  54    function TokenizeNextLine: string;
  55    // Return the Parse Kind for the Current tokenized statement
  56    function IsValidStatement: TIBParseKind;
  57    procedure RemoveComment;
  58    function AppendNextLine: Boolean;
  59    procedure LoadInput;
  60  protected
  61    { Protected declarations }
  62    procedure DoOnParse(AKind: TIBParseKind; SQLText: string); virtual;
  63    procedure DoOnError(Error: string; SQLText: string); virtual;
  64    procedure DoParser;
  65  public
  66    { Public declarations }
  67    constructor Create(AOwner: TComponent); override;
  68    destructor Destroy; override;
  69    procedure Parse;
  70    property CurrentLine: Integer read LineIndex;
  71    property CurrentTokens: TStrings read FTokens;
  72  published
  73    { Published declarations }
  74    property Finished: Boolean read FFinished;
  75    property Paused: Boolean read FPaused write SetPaused;
  76    property Script: TStrings read FScript write SetScript;
  77    property Terminator: string read FTerminator write FTerminator;
  78    property OnParse: TIBSQLParseStmt read FOnParse write FOnParse;
  79    property OnError: TIBSQLParseError read FOnError write FOnError;
  80  end;
  81
  82  TIBScriptStats = class
  83  private
  84    FBuffers: int64;
  85    FReadIdx: int64;
  86    FWrites: int64;
  87    FFetches: int64;
  88    FSeqReads: int64;
  89    FReads: int64;
  90    FDeltaMem: int64;
  91
  92    FStartBuffers: int64;
  93    FStartReadIdx: int64;
  94    FStartWrites: int64;
  95    FStartFetches: int64;
  96    FStartSeqReads: int64;
  97    FStartReads: int64;
  98    FStartingMem : Int64;
  99
 100    FDatabase: TIBDatabase;
 101
 102    FInfoStats : TIBDatabaseInfo;
 103    procedure SetDatabase(const Value: TIBDatabase);
 104    function AddStringValues( list : TStrings) : int64;
 105  public
 106    constructor Create;
 107    destructor Destroy; override;
 108    procedure Start;
 109    procedure Clear;
 110    procedure Stop;
 111
 112    property Database : TIBDatabase read FDatabase write SetDatabase;
 113    property Buffers : int64 read FBuffers;
 114    property Reads : int64 read FReads;
 115    property Writes : int64 read FWrites;
 116    property SeqReads : int64 read FSeqReads;
 117    property Fetches : int64 read FFetches;
 118    property ReadIdx : int64 read FReadIdx;
 119    property DeltaMem : int64 read FDeltaMem;
 120    property StartingMem : int64 read FStartingMem;
 121  end;
 122
 123
 124  TIBScript = class(TComponent)
 125  private
 126    FSQLParser: TIBSQLParser;
 127    FAutoDDL: Boolean;
 128    FStatsOn: boolean;
 129    FDataset: TIBDataset;
 130    FDatabase: TIBDatabase;
 131    FOnError: TIBSQLParseError;
 132    FOnParse: TIBSQLParseStmt;
 133    FDDLTransaction: TIBTransaction;
 134    FTransaction: TIBTransaction;
 135    FTerminator: string;
 136    FDDLQuery, FDMLQuery: TIBSQL;
 137    FContinue: Boolean;
 138    FOnExecuteError: TIBSQLExecuteError;
 139    FOnParamCheck: TIBScriptParamCheck;
 140    FValidate, FValidating: Boolean;
 141    FStats: TIBScriptStats;
 142    FSQLDialect : Integer;
 143
 144    FCurrentStmt: TIBParseKind;
 145    FExecuting : Boolean;
 146    function GetPaused: Boolean;
 147    procedure SetPaused(const Value: Boolean);
 148    procedure SetTerminator(const Value: string);
 149    procedure SetupNewConnection;
 150    procedure SetDatabase(const Value: TIBDatabase);
 151    procedure SetTransaction(const Value: TIBTransaction);
 152    function StripQuote(const Text: string): string;
 153    function GetScript: TStrings;
 154    procedure SetScript(const Value: TStrings);
 155    function GetSQLParams: TIBXSQLDA;
 156    procedure SetStatsOn(const Value: boolean);
 157    function GetTokens: TStrings;
 158  protected
 159    procedure Notification(AComponent: TComponent;
 160      Operation: TOperation); override;
 161    procedure DoDML(const Text: string); virtual;
 162    procedure DoDDL(const Text: string); virtual;
 163    procedure DoSET(const Text: string); virtual;
 164    procedure DoConnect(const SQLText: string); virtual;
 165    procedure DoCreate(const SQLText: string); virtual;
 166    procedure DropDatabase(const SQLText: string); virtual;
 167
 168    procedure ParserError(Sender: TObject; Error, SQLText: string;
 169      LineIndex: Integer);
 170    procedure ParserParse(Sender: TObject; AKind: TIBParseKind;
 171      SQLText: string);
 172  public
 173    constructor Create(AOwner: TComponent); override;
 174    destructor Destroy; override;
 175    function ValidateScript: Boolean;
 176    procedure ExecuteScript;
 177    function ParamByName(Idx : String) : TIBXSQLVAR;
 178    property Paused: Boolean read GetPaused write SetPaused;
 179    property Params: TIBXSQLDA read GetSQLParams;
 180    property Stats : TIBScriptStats read FStats;
 181    property CurrentTokens : TStrings read GetTokens;
 182    property Validating : Boolean read FValidating;
 183  published
 184    property AutoDDL: Boolean read FAutoDDL write FAutoDDL default true;
 185    property Dataset: TIBDataset read FDataset write FDataset;
 186    property Database: TIBDatabase read FDatabase write SetDatabase;
 187    property Transaction: TIBTransaction read FTransaction write SetTransaction;
 188    property Terminator: string read FTerminator write SetTerminator;
 189    property Script: TStrings read GetScript write SetScript;
 190    property Statistics: boolean read FStatsOn write SetStatsOn default true;
 191    property OnParse: TIBSQLParseStmt read FOnParse write FOnParse;
 192    property OnParseError: TIBSQLParseError read FOnError write FOnError;
 193    property OnExecuteError: TIBSQLExecuteError read FOnExecuteError write
 194      FOnExecuteError;
 195    property OnParamCheck: TIBScriptParamCheck read FOnParamCheck write
 196      FOnParamCheck;
 197  end;
 198
 199implementation
 200
 201uses IBUtils, IB;
 202
 203const
 204  QUOTE = '''';
 205  DBL_QUOTE = '"';
 206
 207{ TIBSQLParser }
 208
 209function TIBSQLParser.AppendNextLine: Boolean;
 210var
 211  FStrings: TStrings;
 212  FIndex: ^Integer;
 213begin
 214  if (FInput.Count > ImportIndex) then
 215  begin
 216    InInput := true;
 217    FStrings := FInput;
 218    FIndex := @ImportIndex;
 219  end
 220  else
 221  begin
 222    InInput := false;
 223    FStrings := FScript;
 224    FIndex := @ScriptIndex;
 225  end;
 226{  if (not InInput) and (FInput.Count <> ImportIndex) then
 227  begin
 228    FStrings := FInput;
 229    FIndex := @ImportIndex;
 230  end
 231  else
 232  begin
 233    FStrings := FScript;
 234    FIndex := @ScriptIndex;
 235  end;    }
 236
 237  if FIndex^ = FStrings.Count then
 238    Result := false
 239  else
 240  begin
 241    Result := true;
 242    repeat
 243      FWork := FWork + CRLF + FStrings[FIndex^];
 244      Inc(FIndex^);
 245    until (FIndex^ = FStrings.Count) or
 246      (Trim(FWork) <> '');
 247  end;
 248end;
 249
 250constructor TIBSQLParser.Create(AOwner: TComponent);
 251begin
 252  inherited;
 253  FScript := TStringList.Create;
 254  FTokens := TStringList.Create;
 255  FInput := TStringList.Create;
 256  ImportIndex := 0;
 257  FTerminator := ';';  {do not localize}
 258end;
 259
 260destructor TIBSQLParser.Destroy;
 261begin
 262  FScript.Free;
 263  FTokens.Free;
 264  FInput.Free;
 265  inherited;
 266end;
 267
 268procedure TIBSQLParser.DoOnError(Error, SQLText: string);
 269begin
 270  if Assigned(FOnError) then
 271    FOnError(Self, Error, SQLText, LineIndex);
 272end;
 273
 274procedure TIBSQLParser.DoOnParse(AKind: TIBParseKind; SQLText: string);
 275begin
 276  if Assigned(FOnParse) then
 277    FOnParse(Self, AKind, SQLText);
 278end;
 279
 280procedure TIBSQLParser.DoParser;
 281var
 282  Stmt: TIBParseKind;
 283  Statement: string;
 284  i: Integer;
 285begin
 286  while ((ScriptIndex < FScript.Count) or
 287    (Trim(FWork) <> '') or
 288    (ImportIndex < FInput.Count)) and
 289    not FPaused do
 290  begin
 291    Statement := TokenizeNextLine;
 292    Stmt := IsValidStatement;
 293    case Stmt of
 294      stmtERR:
 295        DoOnError('Invalid statement', Statement);
 296      stmtTERM:
 297        begin
 298          DoOnParse(Stmt, FTokens[2]);
 299          FTerminator := FTokens[2];
 300        end;
 301      stmtINPUT:
 302        try
 303          LoadInput;
 304        except
 305          on E: Exception do
 306            DoOnError(E.Message, Statement);
 307        end;
 308      stmtEMPTY:
 309        Continue;
 310      stmtSET:
 311        begin
 312          Statement := '';
 313          for i := 1 to FTokens.Count - 1 do
 314            Statement := Statement + FTokens[i] + ' ';
 315          Statement := TrimRight(Statement);
 316          DoOnParse(Stmt, Statement);
 317        end;
 318    else
 319      DoOnParse(stmt, Statement);
 320    end;
 321  end;
 322end;
 323
 324function TIBSQLParser.IsValidStatement: TIBParseKind;
 325var
 326  Token, Token1 : String;
 327begin
 328  if FTokens.Count = 0 then
 329  begin
 330    Result := stmtEmpty;
 331    Exit;
 332  end;
 333  Token := AnsiUpperCase(FTokens[0]);
 334  if Token = 'COMMIT' then  {do not localize}
 335  begin
 336    Result := stmtCOMMIT;
 337    exit;
 338  end;
 339  if Token = 'ROLLBACK' then   {do not localize}
 340  begin
 341    Result := stmtROLLBACK;
 342    Exit;
 343  end;
 344  Token1 := AnsiUpperCase(FTokens[1]);
 345  if FTokens.Count < 2 then
 346  begin
 347    Result := stmtERR;
 348    Exit;
 349  end;
 350  if (Token = 'INSERT') or (Token = 'DELETE') or   {do not localize}
 351    (Token = 'SELECT') or (Token = 'UPDATE') or    {do not localize}
 352    (Token = 'EXECUTE') or                         {do not localize}
 353    ((Token = 'EXECUTE') and (Token1 = 'PROCEDURE')) then  {do not localize}
 354    Result := stmtDML
 355  else
 356    if Token = 'INPUT' then         {do not localize}
 357      Result := stmtINPUT
 358    else
 359      if Token = 'CONNECT' then         {do not localize}
 360        Result := stmtCONNECT
 361      else
 362        if (Token = 'CREATE') and
 363          ((Token1 = 'DATABASE') or (Token1 = 'SCHEMA')) then   {do not localize}
 364          Result := stmtCREATE
 365        else
 366          if (Token = 'DROP') and (Token1 = 'DATABASE') then    {do not localize}
 367            Result := stmtDROP
 368          else
 369            if (Token = 'DECLARE') or (Token = 'CREATE') or (Token = 'ALTER') or {do not localize}
 370              (Token = 'GRANT') or (Token = 'REVOKE') or (Token = 'DROP') or        {do not localize}
 371              ((Token = 'SET') and ((Token1 = 'GENERATOR'))) then  {do not localize}
 372              Result := stmtDDL
 373            else
 374              if (Token = 'SET') then       {do not localize}
 375              begin
 376                if (Token1 = 'TERM') then     {do not localize}
 377                  if FTokens.Count = 3 then
 378                    Result := stmtTERM
 379                  else
 380                    Result := stmtERR
 381                else
 382                  if (Token1 = 'SQL') then  {do not localize}
 383                     if (FTokens.Count = 4) and
 384                        (AnsiUpperCase(FTokens[2]) = 'DIALECT') then  {do not localize}
 385                       Result := stmtSET
 386                     else
 387                       Result := stmtERR
 388                  else
 389                    if (Token1 = 'AUTODDL') or (Token1 = 'STATISTICS') then {do not localize}
 390                      if FTokens.Count = 3 then
 391                        Result := stmtSET
 392                      else
 393                        Result := stmtERR
 394                    else
 395                      Result := stmtERR;
 396              end
 397              else
 398                Result := stmtERR;
 399end;
 400
 401procedure TIBSQLParser.LoadInput;
 402var
 403  FileName: string;
 404begin
 405  FInput.Clear;
 406  ImportIndex := 0;
 407  FileName := FTokens[1];
 408  if FileName[1] in [QUOTE, DBL_QUOTE] then
 409    Delete(FileName, 1, 1);
 410  if FileName[Length(FileName)] in [QUOTE, DBL_QUOTE] then
 411    Delete(FileName, Length(FileName), 1);
 412
 413  FInput.LoadFromFile(FileName);
 414end;
 415
 416procedure TIBSQLParser.Parse;
 417begin
 418  ScriptIndex := 0;
 419  ImportIndex := 0;
 420  FInput.Clear;
 421  FPaused := false;
 422  DoParser;
 423end;
 424
 425procedure TIBSQLParser.RemoveComment;
 426var
 427  Start, Ending: Integer;
 428begin
 429  FWork := TrimLeft(FWork);
 430  Start := AnsiPos('/*', FWork);    {do not localize}
 431  while Start = 1 do
 432  begin
 433    Ending := AnsiPos('*/', FWork); {do not localize}
 434    while Ending < Start do
 435    begin
 436      if AppendNextLine = false then
 437        raise Exception.Create('Invalid Comment');
 438      Ending := AnsiPos('*/', FWork);    {do not localize}
 439    end;
 440    Delete(FWork, Start, Ending - Start + 2);
 441    FWork := TrimLeft(FWork);
 442    if FWork = '' then
 443      AppendNextLine;
 444    FWork := TrimLeft(FWork);
 445    Start := AnsiPos('/*', FWork);    {do not localize}
 446  end;
 447  FWork := TrimLeft(FWork);
 448end;
 449
 450procedure TIBSQLParser.SetPaused(const Value: Boolean);
 451begin
 452  if FPaused <> Value then
 453  begin
 454    FPaused := Value;
 455    if not FPaused then
 456      DoParser;
 457  end;
 458end;
 459
 460procedure TIBSQLParser.SetScript(const Value: TStrings);
 461begin
 462  FScript.Assign(Value);
 463  FPaused := false;
 464  ScriptIndex := 0;
 465  ImportIndex := 0;
 466  FInput.Clear;
 467end;
 468
 469{ Note on TokenizeNextLine.  This is not intended to actually tokenize in
 470  terms of SQL tokens.  It has two goals.  First is to get the primary statement
 471  type in FTokens[0].  These are items like SELECT, UPDATE, CREATE, SET, IMPORT.
 472  The secondary function is to correctly find the end of a statement.  So if the
 473  terminator is ; and the statement is "SELECT 'FDR'';' from Table1;" while
 474  correct SQL tokenization is SELECT, 'FDR'';', FROM, Table1 but this is more
 475  than needed.  The Tokenizer will tokenize this as SELECT, 'FDR', ';', FROM,
 476  Table1.  We get that it is a SELECT statement and get the correct termination
 477  and whole statement in the case where the terminator is embedded inside
 478  a ' or ". }
 479
 480function TIBSQLParser.TokenizeNextLine: string;
 481var
 482  InQuote, InDouble, InComment, Done: Boolean;
 483  NextWord: string;
 484  Index: Integer;
 485
 486  procedure ScanToken;
 487  var
 488    SDone: Boolean;
 489  begin
 490    NextWord := '';
 491    SDone := false;
 492    Index := 1;
 493    while (Index <= Length(FWork)) and (not SDone) do
 494    begin
 495      { Hit the terminator, but it is not embedded in a single or double quote
 496          or inside a comment }
 497      if ((not InQuote) and (not InDouble) and (not InComment)) and
 498        (CompareStr(FTerminator, Copy(FWork, Index, Length(FTerminator))) = 0)
 499          then
 500      begin
 501        Done := true;
 502        Result := Result + NextWord;
 503        Delete(FWork, 1, Length(NextWord) + Length(FTerminator));
 504        NextWord := Trim(AnsiUpperCase(NextWord));
 505        if NextWord <> '' then
 506          FTokens.Add(AnsiUpperCase(NextWord));
 507        Exit;
 508      end;
 509
 510      { Are we entering or exiting an inline comment? }
 511      if (Index < Length(FWork)) and ((not Indouble) or (not InQuote)) and
 512        (FWork[Index] = '/') and (FWork[Index + 1] = '*') then     {do not localize}
 513        InComment := true;
 514      if InComment and (Index <> 1) and
 515         (FWork[Index] = '/') and (FWork[Index - 1] = '*') then     {do not localize}
 516        InComment := false;
 517
 518      if not InComment then
 519        { Handle case when the character is a single quote or a double quote }
 520        case FWork[Index] of
 521          QUOTE:
 522            if not InDouble then
 523            begin
 524              if InQuote then
 525              begin
 526                InQuote := false;
 527                SDone := true;
 528              end
 529              else
 530                InQuote := true;
 531            end;
 532          DBL_QUOTE:
 533            if not InQuote then
 534            begin
 535              if InDouble then
 536              begin
 537                Indouble := false;
 538                SDone := true;
 539              end
 540              else
 541                InDouble := true;
 542            end;
 543          ' ':                   {do not localize}
 544            if (not InDouble) and (not InQuote) then
 545              SDone := true;
 546        end;
 547      NextWord := NextWord + FWork[Index];
 548      Inc(Index);
 549    end;
 550    { copy over the remaining non character or spaces until the next word }
 551    while (Index <= Length(FWork)) and (FWork[Index] <= #32) do
 552    begin
 553      NextWord := NextWord + FWork[Index];
 554      Inc(Index);
 555    end;
 556    Result := Result + NextWord;
 557    Delete(FWork, 1, Length(NextWord));
 558    NextWord := Trim(NextWord);
 559    if NextWord <> '' then
 560      FTokens.Add(NextWord);
 561  end;
 562
 563begin
 564  FTokens.Clear;
 565  if FWork = '' then
 566    AppendNextLine;
 567  if not InInput then
 568    LineIndex := ScriptIndex;
 569  try
 570    RemoveComment;
 571  except
 572    on E: Exception do
 573    begin
 574      DoOnError(E.Message, '');
 575      exit;
 576    end
 577  end;
 578  InQuote := false;
 579  InDouble := false;
 580  InComment := false;
 581  Done := false;
 582  Result := '';
 583  while not Done do
 584  begin
 585    { Check the work queue, if it is empty get the next line to process }
 586    if FWork = '' then
 587      if not AppendNextLine then
 588        exit;
 589    ScanToken;
 590  end;
 591end;
 592
 593{ TIBScript }
 594
 595constructor TIBScript.Create(AOwner: TComponent);
 596begin
 597  inherited;
 598  FSQLParser := TIBSQLParser.Create(self);
 599  FSQLParser.OnError := ParserError;
 600  FSQLParser.OnParse := ParserParse;
 601  Terminator := ';';                    {do not localize}
 602  FDDLTransaction := TIBTransaction.Create(self);
 603  FDDLQuery := TIBSQL.Create(self);
 604  FDDLQuery.ParamCheck := false;
 605  FAutoDDL := true;
 606  FStatsOn := true;
 607  FStats := TIBScriptStats.Create;
 608  FStats.Database := FDatabase;
 609  FSQLDialect := 3;
 610end;
 611
 612destructor TIBScript.Destroy;
 613begin
 614  FStats.Free;
 615  inherited;
 616end;
 617
 618procedure TIBScript.DoConnect(const SQLText: string);
 619var
 620  i: integer;
 621  Param: string;
 622begin
 623  SetupNewConnection;
 624  if Database.Connected then
 625    Database.Connected := false;
 626  Database.SQLDialect := FSQLDialect;
 627  Database.Params.Clear;
 628  Database.DatabaseName := StripQuote(FSQLParser.CurrentTokens[1]);
 629  i := 2;
 630  while i < FSQLParser.CurrentTokens.Count - 1 do
 631  begin
 632    if AnsiCompareText(FSQLParser.CurrentTokens[i], 'USER') = 0 then   {do not localize}
 633      Param := 'user_name';                                            {do not localize}
 634    if AnsiCompareText(FSQLParser.CurrentTokens[i], 'PASSWORD') = 0 then  {do not localize}
 635      Param := 'password';                                              {do not localize}
 636    if AnsiCompareText(FSQLParser.CurrentTokens[i], 'ROLE') = 0 then   {do not localize}
 637      Param := 'user_role';                                            {do not localize}
 638    Database.Params.Add(Param + '=' + StripQuote(FSQLParser.CurrentTokens[i +
 639      1]));
 640    Inc(i, 2);
 641  end;
 642  Database.Connected := true;
 643end;
 644
 645procedure TIBScript.DoCreate(const SQLText: string);
 646var
 647  i: Integer;
 648begin
 649  SetupNewConnection;
 650  FDatabase.DatabaseName := StripQuote(FSQLParser.CurrentTokens[2]);
 651  i := 3;
 652  while i < FSQLParser.CurrentTokens.Count - 1 do
 653  begin
 654    Database.Params.Add(FSQLParser.CurrentTokens[i] + ' ' +
 655      FSQLParser.CurrentTokens[i + 1]);
 656    Inc(i, 2);
 657  end;
 658  FDatabase.SQLDialect := FSQLDialect;
 659  FDatabase.CreateDatabase;
 660  if FStatsOn and Assigned(FDatabase) and FDatabase.Connected then
 661    FStats.Start;
 662end;
 663
 664procedure TIBScript.DoDDL(const Text: string);
 665begin
 666  if AutoDDL then
 667    FDDLQuery.Transaction := FDDLTransaction
 668  else
 669    FDDLQuery.Transaction := FTransaction;
 670
 671  if not FDDLQuery.Transaction.InTransaction then
 672    FDDLQuery.Transaction.StartTransaction;
 673
 674  FDDLQuery.SQL.Text := Text;
 675{!!!!!!!!!!!! ??????????. ?????? ???? ?/? ????? ??????? ???????????,
 676 ?? ???????????? ?????? ??, ? ?? ???? ?????? ?? ?????. Julia
 677
 678  FDDLQuery.ExecQuery;
 679  if AutoDDL then
 680    FDDLTransaction.Commit;}
 681{!!!} // ?????????? ?????? ? ???????????. JKL.
 682  try
 683    FDDLQuery.ExecQuery;
 684    if AutoDDL then
 685      FDDLTransaction.Commit;
 686  except
 687    if AutoDDL then
 688//      FDDLTransaction.Rollback
 689      FDDLTransaction.Commit
 690    else
 691      raise;
 692  end;
 693 {!!!!!!!!!!!!!!!!!!!}
 694end;
 695
 696procedure TIBScript.DoDML(const Text: string);
 697var
 698  FPaused : Boolean;
 699begin
 700  FPaused := false;
 701  if Assigned(FDataSet) then
 702  begin
 703    if FDataSet.Active then
 704      FDataSet.Close;
 705    FDataSet.SelectSQL.Text := Text;
 706    FDataset.Prepare;
 707    if (FDataSet.Params.Count <> 0) and Assigned(FOnParamCheck) then
 708    begin
 709      FOnParamCheck(self, FPaused);
 710      if FPaused then
 711      begin
 712        FSQLParser.Paused := true;
 713        exit;
 714      end;
 715    end;
 716    if FDataset.SQLType = SQLSelect then
 717      FDataSet.Open
 718    else
 719      FDataset.ExecSQL;
 720  end
 721  else
 722  begin
 723    if FDMLQuery.Open then
 724      FDMLQuery.Close;
 725    FDMLQuery.SQL.Text := Text;
 726    FDMLQuery.Prepare;
 727    if (FDMLQuery.Params.Count <> 0) and Assigned(FOnParamCheck) then
 728    begin
 729      FOnParamCheck(self, FPaused);
 730      if FPaused then
 731      begin
 732        FSQLParser.Paused := true;
 733        exit;
 734      end;
 735    end;
 736    FDMLQuery.ExecQuery;
 737  end;
 738end;
 739
 740procedure TIBScript.DoSET(const Text: string);
 741begin
 742  if AnsiCompareText('AUTODDL', FSQLParser.CurrentTokens[1]) = 0 then    {do not localize}
 743    FAutoDDL := FSQLParser.CurrentTokens[2] = 'ON'                    {do not localize}
 744  else
 745    if AnsiCompareText('STATISTICS', FSQLParser.CurrentTokens[1]) = 0 then {do not localize}
 746      Statistics := FSQLParser.CurrentTokens[2] = 'ON'               {do not localize}
 747    else
 748      if (AnsiCompareText('SQL', FSQLParser.CurrentTokens[1]) = 0) and  {do not localize}
 749         (AnsiCompareText('DIALECT', FSQLParser.CurrentTokens[2]) = 0) then  {do not localize}
 750      begin
 751        FSQLDialect := StrToInt(FSQLParser.CurrentTokens[3]);
 752        if Database.SQLDialect <> FSQLDialect then
 753        begin
 754          if Database.Connected then
 755          begin
 756            Database.Close;
 757            Database.SQLDialect := FSQLDialect;
 758            Database.Open;
 759          end
 760          else
 761            Database.SQLDialect := FSQLDialect;
 762        end;
 763      end;
 764end;
 765
 766procedure TIBScript.DropDatabase(const SQLText: string);
 767begin
 768  FDatabase.DropDatabase;
 769end;
 770
 771procedure TIBScript.ExecuteScript;
 772begin
 773  FContinue := true;
 774  FExecuting := true;
 775  if not Assigned(FDataset) then
 776    FDMLQuery := TIBSQL.Create(FDatabase);
 777  try
 778    FStats.Clear;
 779    if FStatsOn and Assigned(FDatabase) and FDatabase.Connected then
 780      FStats.Start;
 781    FSQLParser.Parse;
 782    if FStatsOn then
 783      FStats.Stop;
 784  finally
 785    FExecuting := false;
 786    if Assigned(FDMLQuery) then
 787      FreeAndNil(FDMLQuery);
 788  end;
 789end;
 790
 791function TIBScript.GetPaused: Boolean;
 792begin
 793  Result := FSQLParser.Paused;
 794end;
 795
 796function TIBScript.GetScript: TStrings;
 797begin
 798  Result := FSQLParser.Script;
 799end;
 800
 801function TIBScript.GetSQLParams: TIBXSQLDA;
 802begin
 803  if Assigned(FDataset) then
 804    Result := FDataset.Params
 805  else
 806    Result := FDMLQuery.Params;
 807end;
 808
 809function TIBScript.GetTokens: TStrings;
 810begin
 811  Result := FSQLParser.CurrentTokens;
 812end;
 813
 814procedure TIBScript.Notification(AComponent: TComponent;
 815  Operation: TOperation);
 816begin
 817  inherited;
 818  if Operation = opRemove then
 819  begin
 820    if AComponent = FDataset then
 821      FDataset := nil
 822    else
 823      if AComponent = FDatabase then
 824        FDatabase := nil
 825      else
 826        if AComponent = FTransaction then
 827          FTransaction := nil;
 828  end;
 829end;
 830
 831function TIBScript.ParamByName(Idx: String): TIBXSQLVAR;
 832begin
 833  if Assigned(FDataset) then
 834    Result := FDataset.ParamByName(Idx)
 835  else
 836    Result := FDMLQuery.ParamByName(Idx);
 837end;
 838
 839procedure TIBScript.ParserError(Sender: TObject; Error,
 840  SQLText: string; LineIndex: Integer);
 841begin
 842  if Assigned(FOnError) then
 843    FOnError(Self, Error, SQLText, LineIndex);
 844  FValidate := false;
 845  FSQLParser.Paused := true;
 846end;
 847
 848procedure TIBScript.ParserParse(Sender: TObject; AKind: TIBParseKind;
 849  SQLText: string);
 850begin
 851  try
 852    FCurrentStmt := AKind;
 853    if not FValidating then
 854      case AKind of
 855        stmtDrop : DropDatabase(SQLText);
 856        stmtDDL : DoDDL(SQLText);
 857        stmtDML: DoDML(SQLText);
 858        stmtSET: DoSET(SQLText);
 859        stmtCONNECT: DoConnect(SQLText);
 860        stmtCREATE: DoCreate(SQLText);
 861        stmtTERM: FTerminator := Trim(SQLText);
 862        stmtCOMMIT:
 863          if FTransaction.InTransaction then
 864            FTransaction.Commit;
 865        stmtROLLBACK:
 866          if FTransaction.InTransaction then
 867            FTransaction.Rollback
 868      end;
 869    if Assigned(FOnParse) then
 870      FOnParse(self, AKind, SQLText);
 871  except
 872    on E: EIBError do
 873    begin
 874      FContinue := false;
 875      FValidate := false;
 876      FSQLParser.Paused := true;
 877      if Assigned(FOnExecuteError) then
 878        FOnExecuteError(Self, E.Message, SQLText, FSQLParser.CurrentLine,
 879          FContinue)
 880      else
 881        raise;
 882      if FContinue then
 883        FSQLParser.Paused := false;
 884    end;
 885  end;
 886end;
 887
 888procedure TIBScript.SetDatabase(const Value: TIBDatabase);
 889begin
 890  if FDatabase <> Value then
 891  begin
 892    FDatabase := Value;
 893    FDDLQuery.Database := Value;
 894    FDDLTransaction.DefaultDatabase := Value;
 895    FStats.Database := Value;
 896    if Assigned(FDMLQuery) then
 897      FDMLQuery.Database := Value;
 898  end;
 899end;
 900
 901procedure TIBScript.SetPaused(const Value: Boolean);
 902begin
 903  if FSQLParser.Paused and (FCurrentStmt = stmtDML) then
 904    if Assigned(FDataSet) then
 905    begin
 906      if FDataset.SQLType = SQLSelect then
 907        FDataSet.Open
 908      else
 909        FDataset.ExecSQL;
 910    end
 911    else
 912    begin
 913      FDMLQuery.ExecQuery;
 914    end;
 915  FSQLParser.Paused := Value;
 916end;
 917
 918procedure TIBScript.SetScript(const Value: TStrings);
 919begin
 920  FSQLParser.Script.Assign(Value);
 921end;
 922
 923procedure TIBScript.SetStatsOn(const Value: boolean);
 924begin
 925  if FStatsOn <> Value then
 926  begin
 927    FStatsOn := Value;
 928    if FExecuting then
 929    begin
 930      if FStatsOn then
 931        FStats.Start
 932      else
 933        FStats.Stop;
 934    end;
 935  end;
 936end;
 937
 938procedure TIBScript.SetTerminator(const Value: string);
 939begin
 940  if FTerminator <> Value then
 941  begin
 942    FTerminator := Value;
 943    FSQLParser.Terminator := Value;
 944  end;
 945end;
 946
 947procedure TIBScript.SetTransaction(const Value: TIBTransaction);
 948begin
 949  FTransaction := Value;
 950  if Assigned(FDMLQuery) then
 951    FDMLQuery.Transaction := Value;
 952end;
 953
 954procedure TIBScript.SetupNewConnection;
 955begin
 956  FDDLTransaction.RemoveDatabase(FDDLTransaction.FindDatabase(FDatabase));
 957  if FDatabase.Owner = self then
 958    FDatabase.Free;
 959  Database := TIBDatabase.Create(self);
 960  if FTransaction.Owner = self then
 961    FTransaction.Free;
 962  FTransaction := TIBTransaction.Create(self);
 963  FDatabase.DefaultTransaction := FTransaction;
 964  FTransaction.DefaultDatabase := FDatabase;
 965  FDDLTransaction.DefaultDatabase := FDatabase;
 966  FDDLQuery.Database := FDatabase;
 967  if Assigned(FDataset) then
 968  begin
 969    FDataset.Database := FDatabase;
 970    FDataset.Transaction := FTransaction;
 971  end;
 972end;
 973
 974function TIBScript.StripQuote(const Text: string): string;
 975begin
 976  Result := Text;
 977  if Result[1] in [Quote, DBL_QUOTE] then
 978  begin
 979    Delete(Result, 1, 1);
 980    Delete(Result, Length(Result), 1);
 981  end;
 982end;
 983
 984function TIBScript.ValidateScript: Boolean;
 985begin
 986  FValidating := true;
 987  FValidate := true;
 988  FSQLParser.Parse;
 989  Result := FValidate;
 990  FValidating := false;
 991end;
 992
 993{ TIBScriptStats }
 994
 995function TIBScriptStats.AddStringValues(list: TStrings): int64;
 996var
 997  i : integer;
 998  index : integer;
 999begin
1000  try
1001    Result := 0;
1002    for i := 0 to list.count-1 do
1003    begin
1004      index := Pos('=', list.strings[i]);   {do not localize}
1005      if index > 0 then
1006        Result := Result + StrToInt(Copy(list.strings[i], index + 1, 255));
1007    end;
1008  except
1009    Result := 0;
1010  end;
1011end;
1012
1013procedure TIBScriptStats.Clear;
1014begin
1015  FBuffers := 0;
1016  FReads := 0;
1017  FWrites := 0;
1018  FSeqReads := 0;
1019  FFetches := 0;
1020  FReadIdx := 0;
1021  FDeltaMem := 0;
1022end;
1023
1024constructor TIBScriptStats.Create;
1025begin
1026  FInfoStats := TIBDatabaseInfo.Create(nil);
1027end;
1028
1029destructor TIBScriptStats.Destroy;
1030begin
1031  FInfoStats.Destroy;
1032  inherited;
1033end;
1034
1035procedure TIBScriptStats.SetDatabase(const Value: TIBDatabase);
1036begin
1037  FDatabase := Value;
1038  FInfoStats.Database := Value;
1039end;
1040
1041procedure TIBScriptStats.Start;
1042begin
1043  FStartBuffers := FInfoStats.NumBuffers;
1044  FStartReads := FInfoStats.Reads;
1045  FStartWrites := FInfoStats.Writes;
1046  FStartSeqReads := AddStringValues(FInfoStats.ReadSeqCount);
1047  FStartFetches := FInfoStats.Fetches;
1048  FStartReadIdx := AddStringValues(FInfoStats.ReadIdxCount);
1049  FStartingMem := FInfoStats.CurrentMemory;
1050end;
1051
1052procedure TIBScriptStats.Stop;
1053begin
1054  FBuffers := FInfoStats.NumBuffers - FStartBuffers + FBuffers;
1055  FReads := FInfoStats.Reads - FStartReads + FReads;
1056  FWrites := FInfoStats.Writes - FStartWrites + FWrites;
1057  FSeqReads := AddStringValues(FInfoStats.ReadSeqCount) - FStartSeqReads + FSeqReads;
1058  FReadIdx := AddStringValues(FInfoStats.ReadIdxCount) - FStartReadIdx + FReadIdx;
1059  FFetches := FInfoStats.Fetches - FStartFetches + FFetches;
1060  FDeltaMem := FInfoStats.CurrentMemory - FStartingMem + FDeltaMem;
1061end;
1062
1063end.
1064