ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/ibxscript.pas
Revision: 272
Committed: Mon Feb 4 13:34:37 2019 UTC (5 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 55339 byte(s)
Log Message:
Fixes merged

File Contents

# Content
1 (*
2 * IBX For Lazarus (Firebird Express)
3 *
4 * The contents of this file are subject to the Initial Developer's
5 * Public License Version 1.0 (the "License"); you may not use this
6 * file except in compliance with the License. You may obtain a copy
7 * of the License here:
8 *
9 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
10 *
11 * Software distributed under the License is distributed on an "AS
12 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13 * implied. See the License for the specific language governing rights
14 * and limitations under the License.
15 *
16 * The Initial Developer of the Original Code is Tony Whyman.
17 *
18 * The Original Code is (C) 2014-2017 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26 unit ibxscript;
27
28 {$mode objfpc}{$H+}
29
30 {$codepage UTF8}
31
32 interface
33
34 uses Classes, IBDatabase, IBSQL, IB, IBDataOutput, IBUtils;
35
36 type
37
38 TOnNextLine = procedure(Sender: TObject; Line: string) of object;
39 TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
40
41 { TSQLXMLReader }
42
43 TSQLXMLReader = class(TSQLTokeniser)
44 private
45 type
46 TXMLStates = (stNoXML, stInTag,stInTagBody,
47 stAttribute,stAttributeValue,stQuotedAttributeValue,
48 stInEndTag, stInEndTagBody,
49 stXMLData);
50
51 TXMLTag = (xtNone,xtBlob,xtArray,xtElt);
52
53 TXMLTagDef = record
54 XMLTag: TXMLTag;
55 TagValue: string;
56 end;
57
58 const
59 XMLTagDefs: array [xtBlob..xtElt] of TXMLTagDef = (
60 (XMLTag: xtBlob; TagValue: 'blob'),
61 (XMLTag: xtArray; TagValue: 'array'),
62 (XMLTag: xtElt; TagValue: 'elt')
63 );
64 MaxXMLTags = 20;
65 BlobLineLength = 40;
66
67 public
68 const
69 ibx_blob = 'IBX_BLOB';
70 ibx_array = 'IBX_ARRAY';
71
72 type
73 TBlobData = record
74 BlobIntf: IBlob;
75 SubType: cardinal;
76 end;
77
78 TArrayData = record
79 ArrayIntf: IArray;
80 SQLType: cardinal;
81 relationName: string;
82 columnName: string;
83 dim: cardinal;
84 Size: cardinal;
85 Scale: integer;
86 CharSet: string;
87 bounds: TArrayBounds;
88 CurrentRow: integer;
89 Index: array of integer;
90 end;
91
92 private
93 FDatabase: TIBDatabase;
94 FOnProgressEvent: TOnProgressEvent;
95 FTransaction: TIBTransaction;
96 FXMLState: TXMLStates;
97 FXMLTagStack: array [1..MaxXMLTags] of TXMLTag;
98 FXMLTagIndex: integer;
99 FAttributeName: string;
100 FXMLData: string;
101 FBlobData: array of TBlobData;
102 FCurrentBlob: integer;
103 FBlobBuffer: PChar;
104 FArrayData: array of TArrayData;
105 FCurrentArray: integer;
106 FXMLString: string;
107 function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
108 function GetArrayData(index: integer): TArrayData;
109 function GetArrayDataCount: integer;
110 function GetBlobData(index: integer): TBlobData;
111 function GetBlobDataCount: integer;
112 function GetTagName(xmltag: TXMLTag): string;
113 procedure ProcessAttributeValue(attrValue: string);
114 procedure ProcessBoundsList(boundsList: string);
115 procedure ProcessTagValue(tagValue: string);
116 procedure XMLTagInit(xmltag: TXMLTag);
117 function XMLTagEnd(var xmltag: TXMLTag): boolean;
118 procedure XMLTagEnter;
119 protected
120 function GetErrorPrefix: string; virtual; abstract;
121 function TokenFound(var token: TSQLTokens): boolean; override;
122 procedure Reset; override;
123 procedure ShowError(msg: string; params: array of const); virtual; overload;
124 procedure ShowError(msg: string); overload;
125 public
126 constructor Create;
127 procedure FreeDataObjects;
128 class function FormatBlob(Field: ISQLData): string;
129 class function FormatArray(Database: TIBDatabase; ar: IArray): string;
130 property BlobData[index: integer]: TBlobData read GetBlobData;
131 property BlobDataCount: integer read GetBlobDataCount;
132 property ArrayData[index: integer]: TArrayData read GetArrayData;
133 property ArrayDataCount: integer read GetArrayDataCount;
134 property Database: TIBDatabase read FDatabase write FDatabase;
135 property Transaction: TIBTransaction read FTransaction write FTransaction;
136 property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
137 end;
138
139 { TSQLStatementReader }
140
141 TSQLStatementReader = class(TSQLXMLReader)
142 private
143 type
144 TSQLState = (stDefault, stInStmt, stInBlock, stInArrayDim, stInDeclare);
145 private
146 FHasBegin: boolean;
147 FOnNextLine: TOnNextLine;
148 FTerminator: char;
149 protected
150 procedure EchoNextLine(aLine: string);
151 public
152 constructor Create;
153 function GetNextStatement(var stmt: string) : boolean; virtual;
154 property HasBegin: boolean read FHasBegin;
155 property Terminator: char read FTerminator write FTerminator default DefaultTerminator;
156 property OnNextLine: TOnNextLine read FOnNextLine write FOnNextLine;
157 end;
158
159
160 { TBatchSQLStatementReader }
161
162 {This SQL Reader supports non-interactive parsing of a text file, stream or
163 lines of text.}
164
165 TBatchSQLStatementReader = class(TSQLStatementReader)
166 private
167 FInStream: TStream;
168 FOwnsInStream: boolean;
169 FLineIndex: integer;
170 FIndex: integer;
171 FCurLine: string;
172 protected
173 function GetChar: char; override;
174 function GetErrorPrefix: string; override;
175 public
176 procedure Reset; override;
177 procedure SetStreamSource(Lines: TStrings); overload;
178 procedure SetStreamSource(S: TStream); overload;
179 procedure SetStreamSource(FileName: string); overload;
180 procedure SetStringStreamSource(S: string);
181 end;
182
183 { TInteractiveSQLStatementReader }
184
185 {This SQL reader supports interactive parsing of commands and
186 SQL statements entered at a console}
187
188 TInteractiveSQLStatementReader = class(TSQLStatementReader)
189 private
190 FPrompt: string;
191 FContinuePrompt: string;
192 FTerminated: boolean;
193 FLine: string;
194 FLineIndex: integer;
195 FNextStatement: boolean;
196 function GetNextLine(var Line: string):boolean;
197 protected
198 function GetChar: char; override;
199 function GetErrorPrefix: string; override;
200 public
201 constructor Create(aPrompt: string='SQL>'; aContinue: string = 'CON>');
202 function GetNextStatement(var stmt: string) : boolean; override;
203 property Terminated: boolean read FTerminated write FTerminated;
204 end;
205
206 TGetParamValue = procedure(Sender: TObject; ParamName: string; var BlobID: TISC_QUAD) of object;
207 TLogEvent = procedure(Sender: TObject; Msg: string) of Object;
208 TOnSelectSQL = procedure (Sender: TObject; SQLText: string) of object;
209 TOnSetStatement = procedure(Sender: TObject; command, aValue, stmt: string; var Done: boolean) of object;
210 TOnCreateDatabase = procedure (Sender: TObject; var DatabaseFileName: string) of object;
211
212 { TCustomIBXScript }
213
214 {This is the main script processing engine and can be customised by subclassing
215 and defining the symbol stream appropriate for use.
216
217 The RunScript function is used to invoke the processing of a symbol stream. Each
218 SQL statement is extracted one by one. If it is recognised as a built in command
219 by "ProcessStatement" then it is actioned directly. Otherwise, it is executed
220 using the TIBSQL component. Note that SQL validation by this class is only partial
221 and is sufficient only to parse the SQL into statements. The Firebird engine does
222 the rest when the statement is executed.}
223
224 TCustomIBXScript = class(TComponent)
225 private
226 FEcho: boolean;
227 FSQLReader: TSQLStatementReader;
228 FDatabase: TIBDatabase;
229 FDataOutputFormatter: TIBCustomDataOutput;
230 FIgnoreCreateDatabase: boolean;
231 FIgnoreGrants: boolean;
232 FOnCreateDatabase: TOnCreateDatabase;
233 FOnErrorLog: TLogEvent;
234 FOnSelectSQL: TOnSelectSQL;
235 FOnSetStatement: TOnSetStatement;
236 FShowAffectedRows: boolean;
237 FShowPerformanceStats: boolean;
238 FStopOnFirstError: boolean;
239 FTransaction: TIBTransaction;
240 FInternalTransaction: TIBTransaction;
241 FISQL: TIBSQL;
242 FGetParamValue: TGetParamValue;
243 FOnOutputLog: TLogEvent;
244 FAutoDDL: boolean;
245 procedure DoCommit;
246 procedure DoReconnect;
247 function GetOnProgressEvent: TOnProgressEvent;
248 function GetTransaction: TIBTransaction;
249 procedure SetDatabase(AValue: TIBDatabase);
250 procedure SetDataOutputFormatter(AValue: TIBCustomDataOutput);
251 procedure SetOnProgressEvent(AValue: TOnProgressEvent);
252 procedure SetParamValue(SQLVar: ISQLParam);
253 procedure SetShowPerformanceStats(AValue: boolean);
254 procedure SetTransaction(AValue: TIBTransaction);
255 protected
256 procedure Add2Log(const Msg: string; IsError: boolean=true); virtual;
257 procedure ExecSQL(stmt: string);
258 procedure EchoNextLine(Sender: TObject; Line: string);
259 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
260 function ProcessStatement(stmt: string): boolean; virtual;
261 function ProcessStream: boolean;
262 procedure SetSQLStatementReader(SQLStatementReader: TSQLStatementReader);
263 public
264 constructor Create(aOwner: TComponent); override;
265 destructor Destroy; override;
266 procedure DefaultSelectSQLHandler(aSQLText: string);
267 property SQLStatementReader: TSQLStatementReader read FSQLReader;
268 published
269 property Database: TIBDatabase read FDatabase write SetDatabase;
270 property DataOutputFormatter: TIBCustomDataOutput read FDataOutputFormatter
271 write SetDataOutputFormatter;
272 property AutoDDL: boolean read FAutoDDL write FAutoDDL default true;
273 property Echo: boolean read FEcho write FEcho default true; {Echo Input to Log}
274 property IgnoreGrants: boolean read FIgnoreGrants write FIgnoreGrants;
275 property IgnoreCreateDatabase: boolean read FIgnoreCreateDatabase write FIgnoreCreateDatabase;
276 property Transaction: TIBTransaction read GetTransaction write SetTransaction;
277 property ShowAffectedRows: boolean read FShowAffectedRows write FShowAffectedRows;
278 property ShowPerformanceStats: boolean read FShowPerformanceStats write SetShowPerformanceStats;
279 property StopOnFirstError: boolean read FStopOnFirstError write FStopOnFirstError default true;
280 property GetParamValue: TGetParamValue read FGetParamValue write FGetParamValue; {resolve parameterized queries}
281 property OnOutputLog: TLogEvent read FOnOutputLog write FOnOutputLog; {Log handler}
282 property OnErrorLog: TLogEvent read FOnErrorLog write FOnErrorLog;
283 property OnProgressEvent: TOnProgressEvent read GetOnProgressEvent write SetOnProgressEvent; {Progress Bar Support}
284 property OnSelectSQL: TOnSelectSQL read FOnSelectSQL write FOnSelectSQL; {Handle Select SQL Statements}
285 property OnSetStatement: TOnSetStatement read FOnSetStatement write FOnSetStatement;
286 property OnCreateDatabase: TOnCreateDatabase read FOnCreateDatabase write FOnCreateDatabase;
287 end;
288
289 {
290 TIBXScript: runs an SQL script in the specified file or stream. The text is parsed
291 into SQL statements which are executed in turn. The intention is to be ISQL
292 compatible but with extensions:
293
294 * All DML and DDL Statements are supported.
295
296 * CREATE DATABASE, DROP DATABASE, CONNECT and COMMIT are supported.
297
298 * The following SET statements are supported:
299 SET SQL DIALECT
300 SET TERM
301 SET AUTODDL
302 SET BAIL
303 SET ECHO
304 SET COUNT
305 SET STATS
306 SET NAMES <character set>
307
308 * New Command: RECONNECT. Performs a commit followed by disconnecting and
309 reconnecting to the database.
310
311 * Procedure Bodies (BEGIN .. END blocks) are self-delimiting and do not need
312 an extra terminator. If a terminator is present, this is treated as an
313 empty statement. The result is ISQL compatible, but does not require the
314 use of SET TERM.
315
316 * DML statements may have arguments in IBX format (e.g UPDATE MYTABLE Set data = :mydata).
317 Arguments are valid only for BLOB columns and are resolved using the GetParamValue
318 event. This returns the blobid to be used. A typical use of the event is to
319 read binary data from a file, save it in a blob stream and return the blob id.
320
321 Select SQL statements are not directly supported but can be handled by an external
322 handler (OnSelectSQL event). If the handler is not present then an exception
323 is raised if a Select SQL statement is found.
324
325 Properties:
326
327 * Database: Link to TIBDatabase component
328 * Transaction: Link to Transaction. Defaults to internaltransaction (concurrency, wait)
329 * AutoDDL: When true DDL statements are automatically committed after execution
330 * Echo: boolean. When true, all SQL statements are echoed to log
331 * StopOnFirstError: boolean. When true the script engine terminates on the first
332 SQL Error.
333 * IgnoreGrants: When true, grant statements are silently discarded. This can be
334 useful when applying a script using the Embedded Server.
335 * ShowPerformanceStats: When true, performance statistics (in ISQL format) are
336 written to the log after a DML statement is executed
337 * DataOutputFormatter: Identifies a Data Output Formatter component used to format
338 the results of executing a Select Statement
339
340
341 Events:
342
343 * GetParamValue: called when an SQL parameter is found (in PSQL :name format).
344 This is only called for blob fields. Handler should return the BlobID to be
345 used as the parameter value. If not present an exception is raised when a
346 parameter is found.
347 * OnOutputLog: Called to write SQL Statements to the log (stdout)
348 * OnErrorLog: Called to write all other messages to the log (stderr)
349 * OnProgressEvent: Progress bar support. If Reset is true the value is maximum
350 value of progress bar. Otherwise called to step progress bar.
351 * OnSelectSQL: handler for select SQL statements. If not present, select SQL
352 statements result in an exception.
353 * OnSetStatement: called to process a SET command that has not already been
354 handled by TIBXScript.
355
356 The RunScript function is used to execute an SQL Script and may be called
357 multiple times.
358 }
359
360 { TIBXScript }
361
362 TIBXScript = class(TCustomIBXScript)
363 public
364 constructor Create(aOwner: TComponent); override;
365 {use RunScript instead of PerformUpdate}
366 function PerformUpdate(SQLFile: string; aAutoDDL: boolean): boolean; overload; deprecated;
367 function PerformUpdate(SQLStream: TStream; aAutoDDL: boolean): boolean; overload; deprecated;
368 function RunScript(SQLFile: string): boolean; overload;
369 function RunScript(SQLStream: TStream): boolean; overload;
370 function RunScript(SQLLines: TStrings): boolean; overload;
371 function ExecSQLScript(sql: string): boolean;
372 end;
373
374 function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
375 procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
376
377
378 resourcestring
379 sInvalidSetStatement = 'Invalid %s Statement - %s';
380
381 implementation
382
383 uses Sysutils, RegExpr;
384
385 resourcestring
386 sNoSelectSQL = 'Select SQL Statements are not supported';
387 sNoParamQueries = 'Parameterised Queries are not supported';
388 sResolveQueryParam = 'Resolving Query Parameter: %s';
389 sXMLStackUnderflow = 'XML Stack Underflow';
390 sInvalidEndTag = 'XML End Tag Mismatch - %s';
391 sBadEndTagClosing = 'XML End Tag incorrectly closed';
392 sXMLStackOverFlow = 'XML Stack Overflow';
393 sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
394 sInvalidBoundsList = 'Invalid array bounds list - "%s"';
395 sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
396 sInvalidCharacterSet = 'Unrecognised character set name - "%s"';
397 sOnLineError = 'On Line %d Character %d: ';
398 sArrayIndexError = 'Array Index Error (%d)';
399 sBlobIndexError = 'Blob Index Error (%d)';
400 sStatementError = 'Error processing SQL statement: %s %s - for statement "%s"';
401 sNotInArray = 'elt tag found but not in an XML array tag';
402 sNoDatabase = 'Missing database for xml tag import';
403 sNoTransaction = 'Missing transaction for xml tag import';
404
405 function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
406
407 function ToHex(aValue: byte): string;
408 const
409 HexChars: array [0..15] of char = '0123456789ABCDEF';
410 begin
411 Result := HexChars[aValue shr 4] +
412 HexChars[(aValue and $0F)];
413 end;
414
415 var i, j: integer;
416 begin
417 i := 1;
418 Result := '';
419 if MaxLineLength = 0 then
420 while i <= Length(octetString) do
421 begin
422 Result += ToHex(byte(octetString[i]));
423 Inc(i);
424 end
425 else
426 while i <= Length(octetString) do
427 begin
428 for j := 1 to MaxLineLength do
429 begin
430 if i > Length(octetString) then
431 Exit
432 else
433 Result += ToHex(byte(octetString[i]));
434 inc(i);
435 end;
436 Result += LineEnding;
437 end;
438 end;
439
440 procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
441 begin
442 TextOut.Add(StringToHex(octetString,MaxLineLength));
443 end;
444
445 { TSQLStatementReader }
446
447 procedure TSQLStatementReader.EchoNextLine(aLine: string);
448 begin
449 if assigned(FOnNextLine) then
450 OnNextLine(self,aLine);
451 end;
452
453 constructor TSQLStatementReader.Create;
454 begin
455 inherited Create;
456 Terminator := DefaultTerminator;
457 end;
458
459 function TSQLStatementReader.GetNextStatement(var stmt: string): boolean;
460 var State: TSQLState;
461 Nested: integer;
462 token: TSQLTokens;
463 EndOfStatement: boolean;
464 begin
465 FHasBegin := false;
466 Result := false;
467 EndOfStatement := false;
468 Nested := 0;
469 stmt := '';
470 State := stDefault;
471 while not EOF and not EndOfStatement do
472 begin
473 token := GetNextToken;
474 // writeln(token,' ',TokenText,' ',Terminator);
475 case State of
476 stDefault:
477 {ignore everything before a reserved word}
478 if (token <= high(TSQLReservedWords)) or (token = sqltIdentifier) then
479 begin
480 State := stInStmt;
481 stmt += TokenText;
482 end;
483
484 stInStmt:
485 begin
486 case token of
487 sqltBegin:
488 begin
489 FHasBegin := true;
490 State := stInBlock;
491 Nested := 1;
492 stmt += TokenText;
493 end;
494
495 sqltDeclare:
496 begin
497 State := stInDeclare;
498 stmt += TokenText;
499 end;
500
501 sqltOpenSquareBracket:
502 begin
503 State := stInArrayDim;
504 stmt += TokenText;
505 end;
506
507 sqltComment:
508 stmt += '/*' + TokenText + '*/';
509
510 sqltCommentLine:
511 stmt += '/*' + TokenText + ' */' + LineEnding;
512
513 sqltQuotedString:
514 stmt += '''' + SQLSafeString(TokenText) + '''';
515
516 sqltIdentifierInDoubleQuotes:
517 stmt += '"' + TokenText + '"';
518
519 sqltCR: {ignore};
520
521 sqltEOL:
522 stmt += LineEnding;
523
524 else
525 begin
526 if (tokentext = Terminator) and (Nested = 0) then
527 begin
528 EndOfStatement := true;
529 State := stDefault;
530 end
531 else
532 stmt += TokenText;
533 end;
534 end;
535 end;
536
537 {ignore begin..end blocks for Terminator detection }
538
539 stInBlock:
540 begin
541 case token of
542 sqltBegin:
543 begin
544 Inc(Nested);
545 stmt += TokenText;
546 end;
547
548 sqltEnd:
549 begin
550 Dec(Nested);
551 stmt += TokenText;
552 if Nested = 0 then
553 begin
554 State := stDefault;
555 EndOfStatement := true;
556 end;
557 end;
558
559 sqltComment:
560 stmt += '/*' + TokenText + '*/';
561
562 sqltCommentLine:
563 stmt += '/* ' + TokenText + ' */' + LineEnding;
564
565 sqltQuotedString:
566 stmt += '''' + SQLSafeString(TokenText) + '''';
567
568 sqltIdentifierInDoubleQuotes:
569 stmt += '"' + TokenText + '"';
570
571 sqltCR: {ignore};
572
573 sqltEOL:
574 stmt += LineEnding;
575
576 else
577 stmt += TokenText;
578 end;
579 end;
580
581 {ignore array dimensions for Terminator detection }
582
583 stInArrayDim:
584 begin
585 case token of
586
587 sqltComment:
588 stmt += '/*' + TokenText + '*/';
589
590 sqltCommentLine:
591 stmt += '/* ' + TokenText + ' */' + LineEnding;
592
593 sqltCloseSquareBracket:
594 begin
595 stmt += TokenText;
596 State := stInStmt;
597 end;
598
599 sqltCR: {ignore};
600
601 sqltEOL:
602 stmt += LineEnding;
603
604 else
605 stmt += TokenText;
606 end;
607 end;
608
609 {ignore Declare statement for terminator - semi-colon terminates declaration}
610
611 stInDeclare:
612 begin
613 case token of
614
615 sqltComment:
616 stmt += '/*' + TokenText + '*/';
617
618 sqltCommentLine:
619 stmt += '/* ' + TokenText + ' */' + LineEnding;
620
621 sqltSemiColon:
622 begin
623 State := stInStmt;
624 stmt += TokenText;
625 end;
626
627 sqltCR: {ignore};
628
629 sqltEOL:
630 stmt += LineEnding;
631
632 else
633 stmt += TokenText;
634 end;
635 end;
636 end;
637 end;
638 Result := stmt <> '';
639 end;
640
641 { TSQLXMLReader }
642
643 function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
644 var i: TXMLTag;
645 begin
646 Result := false;
647 for i := xtBlob to xtElt do
648 if XMLTagDefs[i].TagValue = tag then
649 begin
650 xmlTag := XMLTagDefs[i].XMLTag;
651 Result := true;
652 break;
653 end;
654 end;
655
656 function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
657 begin
658 if (index < 0) or (index > ArrayDataCount) then
659 ShowError(sArrayIndexError,[index]);
660 Result := FArrayData[index];
661 end;
662
663 function TSQLXMLReader.GetArrayDataCount: integer;
664 begin
665 Result := Length(FArrayData);
666 end;
667
668 function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
669 begin
670 if (index < 0) or (index > BlobDataCount) then
671 ShowError(sBlobIndexError,[index]);
672 Result := FBlobData[index];
673 end;
674
675 function TSQLXMLReader.GetBlobDataCount: integer;
676 begin
677 Result := Length(FBlobData);
678 end;
679
680 function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
681 var i: TXMLTag;
682 begin
683 Result := 'unknown';
684 for i := xtBlob to xtElt do
685 if XMLTagDefs[i].XMLTag = xmltag then
686 begin
687 Result := XMLTagDefs[i].TagValue;
688 Exit;
689 end;
690 end;
691
692 procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
693 begin
694 case FXMLTagStack[FXMLTagIndex] of
695 xtBlob:
696 if FAttributeName = 'subtype' then
697 FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
698 else
699 ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
700
701 xtArray:
702 if FAttributeName = 'sqltype' then
703 FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
704 else
705 if FAttributeName = 'relation_name' then
706 FArrayData[FCurrentArray].relationName := attrValue
707 else
708 if FAttributeName = 'column_name' then
709 FArrayData[FCurrentArray].columnName := attrValue
710 else
711 if FAttributeName = 'dim' then
712 FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
713 else
714 if FAttributeName = 'length' then
715 FArrayData[FCurrentArray].Size := StrToInt(attrValue)
716 else
717 if FAttributeName = 'scale' then
718 FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
719 else
720 if FAttributeName = 'charset' then
721 FArrayData[FCurrentArray].CharSet := attrValue
722 else
723 if FAttributeName = 'bounds' then
724 ProcessBoundsList(attrValue)
725 else
726 ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
727
728 xtElt:
729 if FAttributeName = 'ix' then
730 with FArrayData[FCurrentArray] do
731 Index[CurrentRow] := StrToInt(attrValue)
732 else
733 ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
734 end;
735 end;
736
737 procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
738 var list: TStringList;
739 i,j: integer;
740 begin
741 list := TStringList.Create;
742 try
743 list.Delimiter := ',';
744 list.DelimitedText := boundsList;
745 with FArrayData[FCurrentArray] do
746 begin
747 if dim <> list.Count then
748 ShowError(sInvalidBoundsList,[boundsList]);
749 SetLength(bounds,dim);
750 for i := 0 to list.Count - 1 do
751 begin
752 j := Pos(':',list[i]);
753 if j = 0 then
754 raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
755 bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
756 bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
757 end;
758 end;
759 finally
760 list.Free;
761 end;
762 end;
763
764 procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
765
766 function nibble(hex: char): byte;
767 begin
768 case hex of
769 '0': Result := 0;
770 '1': Result := 1;
771 '2': Result := 2;
772 '3': Result := 3;
773 '4': Result := 4;
774 '5': Result := 5;
775 '6': Result := 6;
776 '7': Result := 7;
777 '8': Result := 8;
778 '9': Result := 9;
779 'a','A': Result := 10;
780 'b','B': Result := 11;
781 'c','C': Result := 12;
782 'd','D': Result := 13;
783 'e','E': Result := 14;
784 'f','F': Result := 15;
785 end;
786 end;
787
788 procedure RemoveWhiteSpace(var hexData: string);
789 var i: integer;
790 begin
791 {Remove White Space}
792 i := 1;
793 while i <= length(hexData) do
794 begin
795 case hexData[i] of
796 ' ',#9,#10,#13:
797 begin
798 if i < Length(hexData) then
799 Move(hexData[i+1],hexData[i],Length(hexData)-i);
800 SetLength(hexData,Length(hexData)-1);
801 end;
802 else
803 Inc(i);
804 end;
805 end;
806 end;
807
808 procedure WriteToBlob(hexData: string);
809 var i,j : integer;
810 blength: integer;
811 P: PChar;
812 begin
813 RemoveWhiteSpace(hexData);
814 if odd(length(hexData)) then
815 ShowError(sBinaryBlockMustbeEven,[nil]);
816 blength := Length(hexData) div 2;
817 IBAlloc(FBlobBuffer,0,blength);
818 j := 1;
819 P := FBlobBuffer;
820 for i := 1 to blength do
821 begin
822 P^ := char((nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]));
823 Inc(j,2);
824 Inc(P);
825 end;
826 FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
827 end;
828
829 begin
830 if tagValue = '' then Exit;
831 case FXMLTagStack[FXMLTagIndex] of
832 xtBlob:
833 WriteToBlob(tagValue);
834
835 xtElt:
836 with FArrayData[FCurrentArray] do
837 ArrayIntf.SetAsString(index,tagValue);
838
839 end;
840 end;
841
842 procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
843 begin
844 if FXMLTagIndex > MaxXMLTags then
845 ShowError(sXMLStackOverFlow,[nil]);
846 Inc(FXMLTagIndex);
847 FXMLTagStack[FXMLTagIndex] := xmltag;
848 FXMLString := '';
849
850 case xmltag of
851 xtBlob:
852 begin
853 Inc(FCurrentBlob);
854 SetLength(FBlobData,FCurrentBlob+1);
855 FBlobData[FCurrentBlob].BlobIntf := nil;
856 FBlobData[FCurrentBlob].SubType := 0;
857 end;
858
859 xtArray:
860 begin
861 Inc(FCurrentArray);
862 SetLength(FArrayData,FCurrentArray+1);
863 with FArrayData[FCurrentArray] do
864 begin
865 ArrayIntf := nil;
866 SQLType := 0;
867 dim := 0;
868 Size := 0;
869 Scale := 0;
870 CharSet := 'NONE';
871 SetLength(Index,0);
872 CurrentRow := -1;
873 end;
874 end;
875
876 xtElt:
877 with FArrayData[FCurrentArray] do
878 Inc(CurrentRow)
879 end;
880 end;
881
882 function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
883 begin
884 if FXMLTagIndex = 0 then
885 ShowError(sXMLStackUnderflow,[nil]);
886
887 xmlTag := FXMLTagStack[FXMLTagIndex];
888 case FXMLTagStack[FXMLTagIndex] of
889 xtBlob:
890 FBlobData[FCurrentBlob].BlobIntf.Close;
891
892 xtArray:
893 FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
894
895 xtElt:
896 Dec(FArrayData[FCurrentArray].CurrentRow);
897 end;
898 Dec(FXMLTagIndex);
899 Result := FXMLTagIndex = 0;
900 end;
901
902 procedure TSQLXMLReader.XMLTagEnter;
903 var aCharSetID: integer;
904 begin
905 if Database = nil then
906 ShowError(sNoDatabase);
907 if Transaction = nil then
908 ShowError(sNoTransaction);
909 case FXMLTagStack[FXMLTagIndex] of
910 xtBlob:
911 begin
912 Database.Connected := true;
913 Transaction.Active := true;
914 FBlobData[FCurrentBlob].BlobIntf := Database.Attachment.CreateBlob(
915 Transaction.TransactionIntf,FBlobData[FCurrentBlob].SubType);
916 end;
917
918 xtArray:
919 with FArrayData[FCurrentArray] do
920 begin
921 Database.Connected := true;
922 Transaction.Active := true;
923 Database.Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
924 SetLength(Index,dim);
925 ArrayIntf := Database.Attachment.CreateArray(
926 Transaction.TransactionIntf,
927 Database.Attachment.CreateArrayMetaData(SQLType,
928 relationName,columnName,Scale,Size,
929 aCharSetID,dim,bounds)
930 );
931 end;
932 end;
933 end;
934
935 {This is where the XML tags are identified and the token stream modified in
936 consequence}
937
938 function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
939
940 procedure NotAnXMLTag;
941 begin
942 begin
943 if FXMLTagIndex = 0 then
944 {nothing to do with XML so go back to processing SQL}
945 begin
946 QueueToken(token);
947 ReleaseQueue(token);
948 FXMLState := stNoXML
949 end
950 else
951 begin
952 {Not an XML tag, so just push back to XML Data}
953 FXMLState := stXMLData;
954 FXMLString += GetQueuedText;
955 ResetQueue;
956 end;
957 end;
958 end;
959
960 var XMLTag: TXMLTag;
961 begin
962 Result := inherited TokenFound(token);
963 if not Result then Exit;
964
965 case FXMLState of
966 stNoXML:
967 if token = sqltLT then
968 begin
969 ResetQueue;
970 QueueToken(token); {save in case this is not XML}
971 FXMLState := stInTag;
972 end;
973
974 stInTag:
975 {Opening '<' found, now looking for tag name or end tag marker}
976 case token of
977 sqltIdentifier:
978 begin
979 if FindTag(TokenText,XMLTag) then
980 begin
981 XMLTagInit(XMLTag);
982 QueueToken(token);
983 FXMLState := stInTagBody;
984 end
985 else
986 NotAnXMLTag;
987 end;
988
989 sqltForwardSlash:
990 FXMLState := stInEndTag;
991
992 else
993 NotAnXMLTag;
994 end {case token};
995
996 stInTagBody:
997 {Tag name found. Now looking for attribute or closing '>'}
998 case token of
999 sqltIdentifier:
1000 begin
1001 FAttributeName := TokenText;
1002 QueueToken(token);
1003 FXMLState := stAttribute;
1004 end;
1005
1006 sqltGT:
1007 begin
1008 ResetQueue;
1009 XMLTagEnter;
1010 FXMLState := stXMLData;
1011 end;
1012
1013 sqltSpace,
1014 sqltCR, sqltEOL:
1015 QueueToken(token);
1016
1017 else
1018 NotAnXMLTag;
1019 end {case token};
1020
1021 stAttribute:
1022 {Attribute name found. Must be followed by an '=', a '>' or another tag name}
1023 case token of
1024 sqltEquals:
1025 begin
1026 QueueToken(token);
1027 FXMLState := stAttributeValue;
1028 end;
1029
1030 sqltSpace,
1031 sqltCR, sqltEOL:
1032 QueueToken(token);
1033
1034 sqltIdentifier:
1035 begin
1036 ProcessAttributeValue('');
1037 FAttributeName := TokenText;
1038 QueueToken(token);
1039 FXMLState := stAttribute;
1040 end;
1041
1042 sqltGT:
1043 begin
1044 ProcessAttributeValue('');
1045 ResetQueue;
1046 XMLTagEnter;
1047 FXMLState := stXMLData;
1048 end;
1049
1050 else
1051 NotAnXMLTag;
1052 end; {case token}
1053
1054 stAttributeValue:
1055 {Looking for attribute value as a single identifier or a double quoted value}
1056 case token of
1057 sqltIdentifier,sqltIdentifierInDoubleQuotes:
1058 begin
1059 ProcessAttributeValue(TokenText);
1060 QueueToken(token);
1061 FXMLState := stInTagBody;
1062 end;
1063
1064 sqltSpace,
1065 sqltCR, sqltEOL:
1066 QueueToken(token);
1067
1068 else
1069 NotAnXMLTag;
1070 end; {case token}
1071
1072 stXMLData:
1073 if token = sqltLT then
1074 begin
1075 QueueToken(token); {save in case this is not XML}
1076 FXMLState := stInTag;
1077 end
1078 else
1079 FXMLString += TokenText;
1080
1081 stInEndTag:
1082 {Opening '</' found, now looking for tag name}
1083 case token of
1084 sqltIdentifier:
1085 begin
1086 if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
1087 begin
1088 QueueToken(token);
1089 FXMLState := stInEndTagBody;
1090 end
1091 else
1092 ShowError(sInvalidEndTag,[TokenText]);
1093 end;
1094 else
1095 NotAnXMLTag;
1096 end {case token};
1097
1098 stInEndTagBody:
1099 {End tag name found, now looping for closing '>'}
1100 case Token of
1101 sqltGT:
1102 begin
1103 ProcessTagValue(FXMLString);
1104 if XMLTagEnd(XMLTag) then
1105 begin
1106 ResetQueue;
1107 QueueToken(sqltColon,':');
1108 case XMLTag of
1109 xtBlob:
1110 QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
1111
1112 xtArray:
1113 QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
1114 end;
1115 ReleaseQueue(token);
1116 FXMLState := stNoXML;
1117 end
1118 else
1119 FXMLState := stXMLData;
1120 end;
1121
1122 sqltSpace,
1123 sqltCR, sqltEOL:
1124 QueueToken(token);
1125
1126 else
1127 ShowError(sBadEndTagClosing);
1128 end; {case token}
1129
1130 end {Case FState};
1131
1132 {Only allow token to be returned if not processing an XML tag}
1133
1134 Result := FXMLState = stNoXML;
1135 end;
1136
1137 procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
1138 begin
1139 raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
1140 end;
1141
1142 procedure TSQLXMLReader.ShowError(msg: string);
1143 begin
1144 ShowError(msg,[nil]);
1145 end;
1146
1147 constructor TSQLXMLReader.Create;
1148 begin
1149 inherited;
1150 FXMLState := stNoXML;
1151 end;
1152
1153 procedure TSQLXMLReader.FreeDataObjects;
1154 begin
1155 FXMLTagIndex := 0;
1156 SetLength(FBlobData,0);
1157 FCurrentBlob := -1;
1158 SetLength(FArrayData,0);
1159 FCurrentArray := -1;
1160 end;
1161
1162 class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
1163 var TextOut: TStrings;
1164 begin
1165 TextOut := TStringList.Create;
1166 try
1167 TextOut.Add(Format('<blob subtype="%d">',[Field.getSubtype]));
1168 StringToHex(Field.AsString,TextOut,BlobLineLength);
1169 TextOut.Add('</blob>');
1170 Result := TextOut.Text;
1171 finally
1172 TextOut.Free;
1173 end;
1174 end;
1175
1176 class function TSQLXMLReader.FormatArray(Database: TIBDatabase; ar: IArray
1177 ): string;
1178 var index: array of integer;
1179 TextOut: TStrings;
1180
1181 procedure AddElements(dim: integer; indent:string = ' ');
1182 var i: integer;
1183 recurse: boolean;
1184 begin
1185 SetLength(index,dim+1);
1186 recurse := dim < ar.GetDimensions - 1;
1187 with ar.GetBounds[dim] do
1188 for i := LowerBound to UpperBound do
1189 begin
1190 index[dim] := i;
1191 if recurse then
1192 begin
1193 TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
1194 AddElements(dim+1,indent + ' ');
1195 TextOut.Add('</elt>');
1196 end
1197 else
1198 if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
1199 (ar.GetCharSetID = 1) then
1200 TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
1201 else
1202 TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
1203 end;
1204 end;
1205
1206 var
1207 s: string;
1208 bounds: TArrayBounds;
1209 i: integer;
1210 boundsList: string;
1211 begin
1212 TextOut := TStringList.Create;
1213 try
1214 s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1215 [ar.GetDimensions,ar.GetSQLType,ar.GetSize,
1216 ar.GetTableName,ar.GetColumnName]);
1217 case ar.GetSQLType of
1218 SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
1219 s += Format(' scale = "%d"',[ ar.GetScale]);
1220 SQL_TEXT,
1221 SQL_VARYING:
1222 s += Format(' charset = "%s"',[Database.Attachment.GetCharsetName(ar.GetCharSetID)]);
1223 end;
1224 bounds := ar.GetBounds;
1225 boundsList := '';
1226 for i := 0 to length(bounds) - 1 do
1227 begin
1228 if i <> 0 then boundsList += ',';
1229 boundsList += Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
1230 end;
1231 s += Format(' bounds="%s"',[boundsList]);
1232 s += '>';
1233 TextOut.Add(s);
1234
1235 SetLength(index,0);
1236 AddElements(0);
1237 TextOut.Add('</array>');
1238 Result := TextOut.Text;
1239 finally
1240 TextOut.Free;
1241 end; end;
1242
1243 procedure TSQLXMLReader.Reset;
1244 begin
1245 inherited Reset;
1246 FreeDataObjects;
1247 FXMLString := '';
1248 FreeMem(FBlobBuffer);
1249 end;
1250
1251
1252
1253 { TIBXScript }
1254
1255 constructor TIBXScript.Create(aOwner: TComponent);
1256 begin
1257 inherited Create(aOwner);
1258 SetSQLStatementReader(TBatchSQLStatementReader.Create);
1259 end;
1260
1261 function TIBXScript.PerformUpdate(SQLFile: string; aAutoDDL: boolean): boolean;
1262 begin
1263 FAutoDDL := aAutoDDL;
1264 Result := RunScript( SQLFile);
1265 end;
1266
1267 function TIBXScript.PerformUpdate(SQLStream: TStream; aAutoDDL: boolean
1268 ): boolean;
1269 begin
1270 FAutoDDL := aAutoDDL;
1271 Result := RunScript(SQLStream);
1272 end;
1273
1274 function TIBXScript.RunScript(SQLFile: string): boolean;
1275 begin
1276 TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLFile);
1277 Result := ProcessStream;
1278 end;
1279
1280 function TIBXScript.RunScript(SQLStream: TStream): boolean;
1281 begin
1282 TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLStream);
1283 Result := ProcessStream;
1284 end;
1285
1286 function TIBXScript.RunScript(SQLLines: TStrings): boolean;
1287 begin
1288 TBatchSQLStatementReader(FSQLReader).SetStreamSource(SQLLines);
1289 Result := ProcessStream;
1290 end;
1291
1292 function TIBXScript.ExecSQLScript(sql: string): boolean;
1293 begin
1294 TBatchSQLStatementReader(FSQLReader).SetStringStreamSource(sql);
1295 Result := ProcessStream;
1296 end;
1297
1298 { TCustomIBXScript }
1299
1300 procedure TCustomIBXScript.Add2Log(const Msg: string; IsError: boolean);
1301 begin
1302 if IsError then
1303 begin
1304 if assigned(OnErrorLog) then OnErrorLog(self,Msg)
1305 end
1306 else
1307 if assigned(FOnOutputLog) then FOnOutputLog(self,Msg)
1308 end;
1309
1310 procedure TCustomIBXScript.DoCommit;
1311 begin
1312 with GetTransaction do
1313 if InTransaction then Commit;
1314 end;
1315
1316 procedure TCustomIBXScript.DoReconnect;
1317 begin
1318 with GetTransaction do
1319 if InTransaction then Commit;
1320 Database.Reconnect;
1321 end;
1322
1323 procedure TCustomIBXScript.ExecSQL(stmt: string);
1324 var DDL: boolean;
1325 I: integer;
1326 begin
1327 Database.Connected := true;
1328 FISQL.SQL.Text := stmt;
1329 FISQL.Transaction := GetTransaction;
1330 FISQL.Transaction.Active := true;
1331 // FISQL.ParamCheck := not FSQLReader.HasBegin; {Probably PSQL}
1332 FISQL.Prepare;
1333 FISQL.Statement.EnableStatistics(ShowPerformanceStats);
1334
1335 if FISQL.SQLStatementType in [SQLInsert, SQLUpdate, SQLDelete] then
1336 begin
1337 {Interpret parameters}
1338 for I := 0 to FISQL.Params.Count - 1 do
1339 SetParamValue(FISQL.Params[I]);
1340 end;
1341
1342 if FISQL.SQLStatementType = SQLSelect then
1343 begin
1344 if assigned(OnSelectSQL) then
1345 OnSelectSQL(self,stmt)
1346 else
1347 DefaultSelectSQLHandler(stmt);
1348 end
1349 else
1350 begin
1351 DDL := FISQL.SQLStatementType = SQLDDL;
1352 if not DDL or not FIgnoreGrants or (Pos('GRANT',AnsiUpperCase(Trim(stmt))) <> 1) then
1353 begin
1354 FISQL.ExecQuery;
1355 if ShowAffectedRows and not DDL then
1356 Add2Log('Rows Affected: ' + IntToStr(FISQL.RowsAffected));
1357 if not DDL then
1358 TIBCustomDataOutput.ShowPerfStats(FISQL.Statement,@Add2Log);
1359 end;
1360
1361 if FAutoDDL and DDL then
1362 FISQL.Transaction.Commit;
1363 FISQL.Close;
1364 end;
1365 FISQL.SQL.Clear;
1366 end;
1367
1368 function TCustomIBXScript.GetOnProgressEvent: TOnProgressEvent;
1369 begin
1370 Result := FSQLReader.OnProgressEvent;
1371 end;
1372
1373 function TCustomIBXScript.GetTransaction: TIBTransaction;
1374 begin
1375 if not (csDesigning in ComponentState) and (FTransaction = nil) then
1376 Result := FInternalTransaction
1377 else
1378 Result := FTransaction;
1379 end;
1380
1381 procedure TCustomIBXScript.EchoNextLine(Sender: TObject; Line: string);
1382 begin
1383 if Echo then Add2Log(Line);
1384 end;
1385
1386 procedure TCustomIBXScript.Notification(AComponent: TComponent;
1387 Operation: TOperation);
1388 begin
1389 inherited Notification(AComponent, Operation);
1390 if (AComponent = FDatabase) and (Operation = opRemove) then
1391 FDatabase := nil;
1392 if (AComponent = FTransaction) and (Operation = opRemove) then
1393 FTransaction := nil;
1394 if (AComponent = DataOutputFormatter) and (Operation = opRemove) then
1395 FDataOutputFormatter := nil;
1396 end;
1397
1398 procedure TCustomIBXScript.SetDatabase(AValue: TIBDatabase);
1399 begin
1400 if not (csLoading in ComponentState) and (FDatabase = AValue) then Exit;
1401 FDatabase := AValue;
1402 FISQL.Database := AValue;
1403 FSQLReader.Database := AValue;
1404 FInternalTransaction.Active := false;
1405 FInternalTransaction.DefaultDatabase := AValue;
1406 end;
1407
1408 procedure TCustomIBXScript.SetDataOutputFormatter(AValue: TIBCustomDataOutput);
1409 begin
1410 if FDataOutputFormatter = AValue then Exit;
1411 if (FDataOutputFormatter <> nil) and (AValue <> nil) then
1412 AValue.Assign(FDataOutputFormatter);
1413 FDataOutputFormatter := AValue;
1414 if FDataOutputFormatter <> nil then
1415 FDataOutputFormatter.Database := Database;
1416 end;
1417
1418 procedure TCustomIBXScript.SetOnProgressEvent(AValue: TOnProgressEvent);
1419 begin
1420 FSQLReader.OnProgressEvent := AValue;
1421 end;
1422
1423 procedure TCustomIBXScript.SetParamValue(SQLVar: ISQLParam);
1424 var BlobID: TISC_QUAD;
1425 ix: integer;
1426 begin
1427 if (SQLVar.SQLType = SQL_BLOB) and (Pos(TSQLXMLReader.ibx_blob,SQLVar.Name) = 1) then
1428 begin
1429 ix := StrToInt(system.copy(SQLVar.Name,length(TSQLXMLReader.ibx_blob)+1,length(SQLVar.Name)-length(TSQLXMLReader.ibx_blob)));
1430 SQLVar.AsBlob := FSQLReader.BlobData[ix].BlobIntf;
1431 Exit;
1432 end
1433 else
1434 if (SQLVar.SQLType = SQL_ARRAY) and (Pos(TSQLXMLReader.ibx_array,SQLVar.Name) = 1) then
1435 begin
1436 ix := StrToInt(system.copy(SQLVar.Name,length(TSQLXMLReader.ibx_array)+1,length(SQLVar.Name)-length(TSQLXMLReader.ibx_array)));
1437 SQLVar.AsArray := FSQLReader.ArrayData[ix].ArrayIntf;
1438 Exit;
1439 end;
1440
1441 if assigned(FGetParamValue) and (SQLVar.SQLType = SQL_BLOB) then
1442 begin
1443 Add2Log(Format(sResolveQueryParam,[SQLVar.Name]));
1444 GetParamValue(self,SQLVar.Name,BlobID);
1445 if (BlobID.gds_quad_high = 0) and (BlobID.gds_quad_low = 0) then
1446 SQLVar.Clear
1447 else
1448 SQLVar.AsQuad := BlobID
1449 end
1450 else
1451 raise Exception.Create(sNoParamQueries);
1452 end;
1453
1454 procedure TCustomIBXScript.SetShowPerformanceStats(AValue: boolean);
1455 begin
1456 if FShowPerformanceStats = AValue then Exit;
1457 FShowPerformanceStats := AValue;
1458 if assigned(DataOutputFormatter) then
1459 DataOutputFormatter.ShowPerformanceStats := AValue;
1460 end;
1461
1462 function TCustomIBXScript.ProcessStream: boolean;
1463 var stmt: string;
1464 begin
1465 Result := false;
1466 while FSQLReader.GetNextStatement(stmt) do
1467 try
1468 stmt := trim(stmt);
1469 // writeln('stmt = ',stmt);
1470 if stmt = '' then continue;
1471 if not ProcessStatement(stmt) then
1472 ExecSQL(stmt);
1473
1474 except on E:Exception do
1475 begin
1476 with GetTransaction do
1477 if InTransaction then Rollback;
1478 FSQLReader.Terminator := TSQLStatementReader.DefaultTerminator;
1479 if assigned(OnErrorLog) then
1480 begin
1481 Add2Log(Format(sStatementError,[FSQLReader.GetErrorPrefix,
1482 E.Message,stmt]),true);
1483 if StopOnFirstError then Exit;
1484 end
1485 else
1486 raise;
1487 end
1488 end;
1489 Result := true;
1490 end;
1491
1492 procedure TCustomIBXScript.SetSQLStatementReader(
1493 SQLStatementReader: TSQLStatementReader);
1494 begin
1495 FSQLReader := SQLStatementReader;
1496 FSQLReader.OnNextLine := @EchoNextLine;
1497 FSQLReader.Transaction := FInternalTransaction;
1498 end;
1499
1500 function TCustomIBXScript.ProcessStatement(stmt: string): boolean;
1501 var command: string;
1502
1503 function Toggle(aValue: string): boolean;
1504 begin
1505 aValue := AnsiUpperCase(aValue);
1506 if aValue = 'ON' then
1507 Result := true
1508 else
1509 if aValue = 'OFF' then
1510 Result := false
1511 else
1512 raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
1513 end;
1514
1515 procedure ExtractUserInfo;
1516 var RegexObj: TRegExpr;
1517 begin
1518 RegexObj := TRegExpr.Create;
1519 try
1520 RegexObj.ModifierG := false; {turn off greedy matches}
1521 RegexObj.Expression := ' +USER +''(.+)''';
1522 if RegexObj.Exec(stmt) then
1523 FDatabase.Params.Values['user_name'] := RegexObj.Match[1];
1524
1525 RegexObj.Expression := ' +PASSWORD +''(.+)''';
1526 if RegexObj.Exec(stmt) then
1527 FDatabase.Params.Values['password'] :=
1528 system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
1529 finally
1530 RegexObj.Free;
1531 end;
1532 end;
1533
1534 procedure ExtractConnectInfo;
1535 var RegexObj: TRegExpr;
1536 begin
1537 ExtractUserInfo;
1538 RegexObj := TRegExpr.Create;
1539 try
1540 RegexObj.ModifierG := false; {turn off greedy matches}
1541 RegexObj.ModifierI := true; {case insensitive}
1542 RegexObj.Expression := '^ *CONNECT +''(.*)''';
1543 if RegexObj.Exec(stmt) then
1544 begin
1545 FDatabase.DatabaseName := system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
1546 end;
1547
1548 RegexObj.Expression := ' +ROLE +''(.+)''';
1549 if RegexObj.Exec(stmt) then
1550 FDatabase.Params.Values['sql_role_name'] := RegexObj.Match[1]
1551 else
1552 with FDatabase.Params do
1553 if IndexOfName('sql_role_name') <> -1 then
1554 Delete(IndexOfName('sql_role_name'));
1555
1556 RegexObj.Expression := ' +CACHE +([0-9]+)';
1557 if RegexObj.Exec(stmt) then
1558 FDatabase.Params.Values['cache_manager'] := RegexObj.Match[1]
1559 else
1560 with FDatabase.Params do
1561 if IndexOfName('cache_manager') <> -1 then
1562 Delete(IndexOfName('cache_manager'));
1563 finally
1564 RegexObj.Free;
1565 end;
1566 end;
1567
1568 procedure UpdateUserPassword;
1569 var RegexObj: TRegExpr;
1570 begin
1571 RegexObj := TRegExpr.Create;
1572 try
1573 RegexObj.ModifierG := false; {turn off greedy matches}
1574 RegexObj.ModifierI := true; {case insensitive}
1575 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'') +USER +''(.+)''';
1576 if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('user_name') <> -1) then
1577 begin
1578 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'')';
1579 if RegexObj.Exec(stmt) then
1580 begin
1581 system.Insert(' USER ''' + FDatabase.Params.Values['user_name'] +'''',stmt,
1582 RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
1583 end;
1584 end;
1585
1586 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +USER +''.+'' PASSWORD +''(.+)''';
1587 if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('password') <> -1) then
1588 begin
1589 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +(USER +''.+'')';
1590 if RegexObj.Exec(stmt) then
1591 begin
1592 system.Insert(' PASSWORD ''' + FDatabase.Params.Values['password'] +'''',stmt,
1593 RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
1594 end;
1595 end;
1596 finally
1597 RegexObj.Free;
1598 end;
1599 end;
1600
1601 var RegexObj: TRegExpr;
1602 n: integer;
1603 charsetid: integer;
1604 param: string;
1605 Terminator: char;
1606 FileName: string;
1607 DBConnected: boolean;
1608 LoginPrompt: boolean;
1609 begin
1610 Result := false;
1611 Terminator := FSQLReader.Terminator;
1612 RegexObj := TRegExpr.Create;
1613 try
1614 {process create database}
1615 RegexObj.ModifierI := true; {case insensitive}
1616 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''(.*)(\' + Terminator + '|)';
1617 if RegexObj.Exec(stmt) then
1618 begin
1619 if IgnoreCreateDatabase then
1620 begin
1621 Result := true;
1622 Exit;
1623 end;
1624 FileName := system.copy(stmt,RegexObj.MatchPos[2], RegexObj.MatchLen[2]);
1625 if assigned(FOnCreateDatabase) then
1626 OnCreateDatabase(self,FileName);
1627 stmt := 'CREATE DATABASE ''' + FileName + '''' + system.copy(stmt,RegexObj.MatchPos[3], RegexObj.MatchLen[3]);
1628 UpdateUserPassword;
1629 if FDatabase.Connected then
1630 FDatabase.Dropdatabase;
1631 FDatabase.CreateDatabase(stmt);
1632 Result := true;
1633 Exit;
1634 end;
1635
1636 {process connect statement}
1637 RegexObj.Expression := '^ *CONNECT +.*(\' + Terminator + '|)';
1638 if RegexObj.Exec(stmt) then
1639 begin
1640 ExtractConnectInfo;
1641 FDatabase.Connected := false;
1642 FDatabase.Connected := true;
1643 Result := true;
1644 Exit;
1645 end;
1646
1647 {Process Drop Database}
1648 RegexObj.Expression := '^ *DROP +DATABASE *(\' + Terminator + '|)';
1649 if RegexObj.Exec(stmt) then
1650 begin
1651 FDatabase.DropDatabase;
1652 Result := true;
1653 Exit;
1654 end;
1655
1656 {process commit statement}
1657 RegexObj.Expression := '^ *COMMIT *(\' + Terminator + '|)';
1658 if RegexObj.Exec(stmt) then
1659 begin
1660 DoCommit;
1661 Result := true;
1662 Exit;
1663 end;
1664
1665 {process Reconnect statement}
1666 RegexObj.Expression := '^ *RECONNECT *(\' + Terminator + '|)';
1667 if RegexObj.Exec(stmt) then
1668 begin
1669 DoReconnect;
1670 Result := true;
1671 Exit;
1672 end;
1673
1674
1675 {Process Set Term}
1676 RegexObj.Expression := '^ *SET +TERM +(.) *(\' + Terminator + '|)';
1677 if RegexObj.Exec(stmt) then
1678 begin
1679 FSQLReader.Terminator := RegexObj.Match[1][1];
1680 Result := true;
1681 Exit;
1682 end;
1683
1684 {process Set SQL Dialect}
1685 RegexObj.Expression := '^ *SET +SQL +DIALECT +([0-9]) *(\' + Terminator + '|)';
1686 if RegexObj.Exec(stmt) then
1687 begin
1688 n := StrToInt(RegexObj.Match[1]);
1689 if Database.SQLDialect <> n then
1690 begin
1691 Database.SQLDialect := n;
1692 if Database.Connected then
1693 DoReconnect;
1694 end;
1695 Result := true;
1696 Exit;
1697 end;
1698
1699 {Process Remaining Set statements}
1700 RegexObj.Expression := '^ *SET +([A-Z]+)( +[A-Z0-9]+|) *(\' + Terminator + '|)';
1701 if RegexObj.Exec(stmt) then
1702 begin
1703 command := AnsiUpperCase(RegexObj.Match[1]);
1704 param := trim(RegexObj.Match[2]);
1705 if command = 'AUTODDL' then
1706 AutoDDL := ((RegexObj.MatchLen[2] = 0) and not AutoDDL) or
1707 (RegexObj.MatchLen[2] > 0) and Toggle(param)
1708 else
1709 if command = 'BAIL' then
1710 StopOnFirstError := ((RegexObj.MatchLen[2] = 0) and not StopOnFirstError) or
1711 (RegexObj.MatchLen[2] > 0) and Toggle(param)
1712 else
1713 if command = 'ECHO' then
1714 Echo := ((RegexObj.MatchLen[2] = 0) and not Echo) or
1715 (RegexObj.MatchLen[2] > 0) and Toggle(param)
1716 else
1717 if command = 'COUNT' then
1718 ShowAffectedRows := ((RegexObj.MatchLen[2] = 0) and not ShowAffectedRows) or
1719 (RegexObj.MatchLen[2] > 0) and Toggle(param)
1720 else
1721 if command = 'STATS' then
1722 ShowPerformanceStats := ((RegexObj.MatchLen[2] = 0) and not FShowPerformanceStats) or
1723 (RegexObj.MatchLen[2] > 0) and Toggle(param)
1724 else
1725 if command = 'NAMES' then
1726 begin
1727 if Database.Attachment.CharSetName2CharSetID(param,charsetid) then
1728 begin
1729 DBConnected := Database.Connected;
1730 LoginPrompt := Database.LoginPrompt;
1731 Database.LoginPrompt := false;
1732 Database.Connected := false;
1733 Database.Params.Values['lc_ctype'] := param;
1734 Database.Connected := DBConnected;
1735 Database.LoginPrompt := LoginPrompt;
1736 end
1737 else
1738 raise Exception.CreateFmt(sInvalidCharacterSet, [param,stmt]);
1739 end
1740 else
1741 begin
1742 if assigned(DataOutputFormatter) then
1743 DataOutputFormatter.SetCommand(command,param,stmt,Result);
1744 if not Result then
1745 begin
1746 if assigned(OnSetStatement) then
1747 OnSetStatement(self,command,param,stmt,Result)
1748 else
1749 raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
1750 end;
1751 Exit;
1752 end;
1753 Result := true;
1754 Exit;
1755 end;
1756
1757 finally
1758 RegexObj.Free;
1759 end;
1760 end;
1761
1762 procedure TCustomIBXScript.SetTransaction(AValue: TIBTransaction);
1763 begin
1764 if FTransaction = AValue then Exit;
1765 FTransaction := AValue;
1766 if FTransaction = nil then
1767 FSQLReader.Transaction := FInternalTransaction
1768 else
1769 FSQLReader.Transaction := FTransaction;
1770 end;
1771
1772 constructor TCustomIBXScript.Create(aOwner: TComponent);
1773 begin
1774 inherited Create(aOwner);
1775 FStopOnFirstError := true;
1776 FEcho := true;
1777 FAutoDDL := true;
1778 FISQL := TIBSQL.Create(self);
1779 FISQL.ParamCheck := true;
1780 FInternalTransaction := TIBTransaction.Create(self);
1781 FInternalTransaction.Params.Clear;
1782 FInternalTransaction.Params.Add('concurrency');
1783 FInternalTransaction.Params.Add('wait');
1784 end;
1785
1786 destructor TCustomIBXScript.Destroy;
1787 begin
1788 if FSQLReader <> nil then FSQLReader.Free;
1789 if FISQL <> nil then FISQL.Free;
1790 if FInternalTransaction <> nil then FInternalTransaction.Free;
1791 inherited Destroy;
1792 end;
1793
1794 procedure TCustomIBXScript.DefaultSelectSQLHandler(aSQLText: string);
1795 begin
1796 if assigned(DataOutputFormatter) then
1797 DataOutputFormatter.DataOut(aSQLText,@Add2Log)
1798 else
1799 FSQLReader.ShowError(sNoSelectSQL);
1800 end;
1801
1802 { TInteractiveSQLStatementReader }
1803
1804 function TInteractiveSQLStatementReader.GetErrorPrefix: string;
1805 begin
1806 Result := '';
1807 end;
1808
1809 function TInteractiveSQLStatementReader.GetNextLine(var Line: string): boolean;
1810 begin
1811 if FNextStatement then
1812 write(FPrompt)
1813 else
1814 write(FContinuePrompt);
1815 Result := not system.EOF;
1816 if Result then
1817 begin
1818 readln(Line);
1819 EchoNextLine(Line);
1820 end;
1821 end;
1822
1823 function TInteractiveSQLStatementReader.GetChar: char;
1824 begin
1825 if Terminated then
1826 Result := #0
1827 else
1828 if FLineIndex > Length(FLine) then
1829 begin
1830 Result := LF;
1831 FLineIndex := 0;
1832 end
1833 else
1834 if FLineIndex = 0 then
1835 begin
1836 if not GetNextLine(FLine) then
1837 Result := #0
1838 else
1839 if Length(FLine) = 0 then
1840 Result := LF
1841 else
1842 begin
1843 Result := FLine[1];
1844 FLineIndex := 2;
1845 end
1846 end
1847 else
1848 begin
1849 Result := FLine[FLineIndex];
1850 Inc(FLineIndex);
1851 end;
1852 end;
1853
1854 constructor TInteractiveSQLStatementReader.Create(aPrompt: string; aContinue: string);
1855 begin
1856 inherited Create;
1857 FPrompt := aPrompt;
1858 FLineIndex := 0;
1859 FNextStatement := true;
1860 FContinuePrompt := aContinue;
1861 end;
1862
1863 function TInteractiveSQLStatementReader.GetNextStatement(var stmt: string
1864 ): boolean;
1865 begin
1866 Result := inherited GetNextStatement(stmt);
1867 FNextStatement := Result;
1868 end;
1869
1870 { TBatchSQLStatementReader }
1871
1872 function TBatchSQLStatementReader.GetChar: char;
1873 begin
1874 if not EOF and assigned(FInStream) and not (FInStream.Position = FInStream.Size) then
1875 begin
1876 Result := char(FInStream.ReadByte);
1877 if Result = LF then
1878 begin
1879 EchoNextLine(FCurLine);
1880 FCurLine := '';
1881 if assigned(OnProgressEvent) then
1882 OnProgressEvent(self,false,FIndex+1);
1883 Inc(FLineIndex);
1884 FIndex := 1;
1885 end
1886 else
1887 begin
1888 FCurLine += Result;
1889 Inc(FIndex);
1890 end;
1891 end
1892 else
1893 Result := #0;
1894 end;
1895
1896 function TBatchSQLStatementReader.GetErrorPrefix: string;
1897 begin
1898 Result := Format(sOnLineError,[FLineIndex,FIndex]);
1899 end;
1900
1901 procedure TBatchSQLStatementReader.Reset;
1902 begin
1903 inherited Reset;
1904 if FOwnsInStream and assigned(FInStream) then
1905 FInStream.Free;
1906 FInStream := nil;
1907 FOwnsInStream := false;
1908 FLineIndex := 1;
1909 FIndex := 1;
1910 end;
1911
1912 procedure TBatchSQLStatementReader.SetStreamSource(Lines: TStrings);
1913 begin
1914 Reset;
1915 FInStream := TMemoryStream.Create;
1916 FOwnsInStream := true;
1917 Lines.SaveToStream(FInStream);
1918 FInStream.Position := 0;
1919 if assigned(OnProgressEvent) then
1920 OnProgressEvent(self,true,FInStream.Size);
1921 end;
1922
1923 procedure TBatchSQLStatementReader.SetStreamSource(S: TStream);
1924 begin
1925 Reset;
1926 FInStream := S;
1927 if assigned(OnProgressEvent) then
1928 OnProgressEvent(self,true,S.Size - S.Position);
1929 end;
1930
1931 procedure TBatchSQLStatementReader.SetStreamSource(FileName: string);
1932 begin
1933 Reset;
1934 FInStream := TFileStream.Create(FileName,fmShareCompat);
1935 FOwnsInStream := true;
1936 if assigned(OnProgressEvent) then
1937 OnProgressEvent(self,true,FInStream.Size);
1938 end;
1939
1940 procedure TBatchSQLStatementReader.SetStringStreamSource(S: string);
1941 begin
1942 Reset;
1943 FInStream := TStringStream.Create(S);
1944 FOwnsInStream := true;
1945 if assigned(OnProgressEvent) then
1946 OnProgressEvent(self,true,FInStream.Size);
1947 end;
1948
1949 end.
1950