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