/Gedemin/IBX/IBScript.pas
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