ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/ibxscript.pas
Revision: 49
Committed: Thu Feb 2 16:20:12 2017 UTC (7 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 59090 byte(s)
Log Message:
Committing updates for Trunk

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