ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/ibxscript.pas
Revision: 229
Committed: Tue Apr 10 13:32:36 2018 UTC (5 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 60682 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
1 (*
2 * IBX For Lazarus (Firebird Express)
3 *
4 * The contents of this file are subject to the Initial Developer's
5 * Public License Version 1.0 (the "License"); you may not use this
6 * file except in compliance with the License. You may obtain a copy
7 * of the License here:
8 *
9 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
10 *
11 * Software distributed under the License is distributed on an "AS
12 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13 * implied. See the License for the specific language governing rights
14 * and limitations under the License.
15 *
16 * The Initial Developer of the Original Code is Tony Whyman.
17 *
18 * The Original Code is (C) 2014-2017 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26 unit ibxscript;
27
28 {$mode objfpc}{$H+}
29
30 {$codepage UTF8}
31
32 interface
33
34 uses Classes, IBDatabase, IBSQL, IB, IBDataOutput;
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 function GetOnProgressEvent: TOnProgressEvent;
297 function GetTransaction: TIBTransaction;
298 procedure SetDatabase(AValue: TIBDatabase);
299 procedure SetDataOutputFormatter(AValue: TIBCustomDataOutput);
300 procedure SetOnProgressEvent(AValue: TOnProgressEvent);
301 procedure SetParamValue(SQLVar: ISQLParam);
302 procedure SetShowPerformanceStats(AValue: boolean);
303 procedure SetTransaction(AValue: TIBTransaction);
304 protected
305 FSymbolStream: TSymbolStream;
306 procedure Add2Log(const Msg: string; IsError: boolean=true); virtual;
307 procedure ExecSQL(stmt: string);
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 if InTransaction then Commit;
565 end;
566
567 procedure TCustomIBXScript.DoReconnect;
568 begin
569 with GetTransaction do
570 if InTransaction then Commit;
571 Database.Reconnect;
572 end;
573
574 procedure TCustomIBXScript.ExecSQL(stmt: string);
575 var DDL: boolean;
576 I: integer;
577 begin
578 Database.Connected := true;
579 FISQL.SQL.Text := stmt;
580 FISQL.Transaction := GetTransaction;
581 FISQL.Transaction.Active := true;
582 FISQL.ParamCheck := not FIBSQLProcessor.HasBegin; {Probably PSQL}
583 FISQL.Prepare;
584 FISQL.Statement.EnableStatistics(ShowPerformanceStats);
585
586 if FISQL.SQLStatementType in [SQLInsert, SQLUpdate, SQLDelete] then
587 begin
588 {Interpret parameters}
589 for I := 0 to FISQL.Params.Count - 1 do
590 SetParamValue(FISQL.Params[I]);
591 end;
592
593 if FISQL.SQLStatementType = SQLSelect then
594 begin
595 if assigned(OnSelectSQL) then
596 OnSelectSQL(self,stmt)
597 else
598 DefaultSelectSQLHandler(stmt);
599 end
600 else
601 begin
602 DDL := FISQL.SQLStatementType = SQLDDL;
603 if not DDL or not FIgnoreGrants or (Pos('GRANT',AnsiUpperCase(Trim(stmt))) <> 1) then
604 begin
605 FISQL.ExecQuery;
606 if ShowAffectedRows and not DDL then
607 Add2Log('Rows Affected: ' + IntToStr(FISQL.RowsAffected));
608 if not DDL then
609 TIBCustomDataOutput.ShowPerfStats(FISQL.Statement,@Add2Log);
610 end;
611
612 if FAutoDDL and DDL then
613 FISQL.Transaction.Commit;
614 FISQL.Close;
615 end;
616 FISQL.SQL.Clear;
617 end;
618
619 function TCustomIBXScript.GetOnProgressEvent: TOnProgressEvent;
620 begin
621 Result := FSymbolStream.OnProgressEvent;
622 end;
623
624 function TCustomIBXScript.GetTransaction: TIBTransaction;
625 begin
626 if not (csDesigning in ComponentState) and (FTransaction = nil) then
627 Result := FInternalTransaction
628 else
629 Result := FTransaction;
630 end;
631
632 procedure TCustomIBXScript.EchoNextLine(Sender: TObject; Line: string);
633 begin
634 if Echo then Add2Log(Line);
635 end;
636
637 procedure TCustomIBXScript.Notification(AComponent: TComponent;
638 Operation: TOperation);
639 begin
640 inherited Notification(AComponent, Operation);
641 if (AComponent = FDatabase) and (Operation = opRemove) then
642 FDatabase := nil;
643 if (AComponent = FTransaction) and (Operation = opRemove) then
644 FTransaction := nil;
645 if (AComponent = DataOutputFormatter) and (Operation = opRemove) then
646 FDataOutputFormatter := nil;
647 end;
648
649 procedure TCustomIBXScript.SetDatabase(AValue: TIBDatabase);
650 begin
651 if not (csLoading in ComponentState) and (FDatabase = AValue) then Exit;
652 FDatabase := AValue;
653 FISQL.Database := AValue;
654 FIBXMLProcessor.Database := AValue;
655 FInternalTransaction.Active := false;
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 with GetTransaction do
727 if InTransaction then Rollback;
728 FSymbolStream.Terminator := DefaultTerminator;
729 if assigned(OnErrorLog) then
730 begin
731 Add2Log(Format(sStatementError,[FSymbolStream.GetErrorPrefix,
732 E.Message,stmt]),true);
733 if StopOnFirstError then Exit;
734 end
735 else
736 raise;
737 end
738 end;
739 Result := true;
740 end;
741
742 function TCustomIBXScript.ProcessStatement(stmt: string): boolean;
743 var command: string;
744
745 function Toggle(aValue: string): boolean;
746 begin
747 aValue := AnsiUpperCase(aValue);
748 if aValue = 'ON' then
749 Result := true
750 else
751 if aValue = 'OFF' then
752 Result := false
753 else
754 raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
755 end;
756
757 procedure ExtractUserInfo;
758 var RegexObj: TRegExpr;
759 begin
760 RegexObj := TRegExpr.Create;
761 try
762 RegexObj.ModifierG := false; {turn off greedy matches}
763 RegexObj.Expression := ' +USER +''(.+)''';
764 if RegexObj.Exec(stmt) then
765 FDatabase.Params.Values['user_name'] := RegexObj.Match[1];
766
767 RegexObj.Expression := ' +PASSWORD +''(.+)''';
768 if RegexObj.Exec(stmt) then
769 FDatabase.Params.Values['password'] :=
770 system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
771 finally
772 RegexObj.Free;
773 end;
774 end;
775
776 procedure ExtractConnectInfo;
777 var RegexObj: TRegExpr;
778 begin
779 ExtractUserInfo;
780 RegexObj := TRegExpr.Create;
781 try
782 RegexObj.ModifierG := false; {turn off greedy matches}
783 RegexObj.ModifierI := true; {case insensitive}
784 RegexObj.Expression := '^ *CONNECT +''(.*)''';
785 if RegexObj.Exec(stmt) then
786 begin
787 FDatabase.DatabaseName := system.copy(stmt,RegexObj.MatchPos[1],RegexObj.MatchLen[1]);
788 end;
789
790 RegexObj.Expression := ' +ROLE +''(.+)''';
791 if RegexObj.Exec(stmt) then
792 FDatabase.Params.Values['sql_role_name'] := RegexObj.Match[1]
793 else
794 with FDatabase.Params do
795 if IndexOfName('sql_role_name') <> -1 then
796 Delete(IndexOfName('sql_role_name'));
797
798 RegexObj.Expression := ' +CACHE +([0-9]+)';
799 if RegexObj.Exec(stmt) then
800 FDatabase.Params.Values['cache_manager'] := RegexObj.Match[1]
801 else
802 with FDatabase.Params do
803 if IndexOfName('cache_manager') <> -1 then
804 Delete(IndexOfName('cache_manager'));
805 finally
806 RegexObj.Free;
807 end;
808 end;
809
810 procedure UpdateUserPassword;
811 var RegexObj: TRegExpr;
812 begin
813 RegexObj := TRegExpr.Create;
814 try
815 RegexObj.ModifierG := false; {turn off greedy matches}
816 RegexObj.ModifierI := true; {case insensitive}
817 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'') +USER +''(.+)''';
818 if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('user_name') <> -1) then
819 begin
820 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +(''.*'')';
821 if RegexObj.Exec(stmt) then
822 begin
823 system.Insert(' USER ''' + FDatabase.Params.Values['user_name'] +'''',stmt,
824 RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
825 end;
826 end;
827
828 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +USER +''.+'' PASSWORD +''(.+)''';
829 if not RegexObj.Exec(stmt) and (FDatabase.Params.IndexOfName('password') <> -1) then
830 begin
831 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''.*'' +(USER +''.+'')';
832 if RegexObj.Exec(stmt) then
833 begin
834 system.Insert(' PASSWORD ''' + FDatabase.Params.Values['password'] +'''',stmt,
835 RegexObj.MatchPos[2] + RegexObj.MatchLen[2]);
836 end;
837 end;
838 finally
839 RegexObj.Free;
840 end;
841 end;
842
843 var RegexObj: TRegExpr;
844 n: integer;
845 charsetid: integer;
846 param: string;
847 Terminator: char;
848 FileName: string;
849 DBConnected: boolean;
850 LoginPrompt: boolean;
851 begin
852 Result := false;
853 Terminator := FSymbolStream.Terminator;
854 RegexObj := TRegExpr.Create;
855 try
856 {process create database}
857 RegexObj.ModifierI := true; {case insensitive}
858 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''(.*)(\' + Terminator + '|)';
859 if RegexObj.Exec(stmt) then
860 begin
861 if IgnoreCreateDatabase then
862 begin
863 Result := true;
864 Exit;
865 end;
866 FileName := system.copy(stmt,RegexObj.MatchPos[2], RegexObj.MatchLen[2]);
867 if assigned(FOnCreateDatabase) then
868 OnCreateDatabase(self,FileName);
869 stmt := 'CREATE DATABASE ''' + FileName + '''' + system.copy(stmt,RegexObj.MatchPos[3], RegexObj.MatchLen[3]);
870 UpdateUserPassword;
871 FDatabase.Connected := false;
872 FDatabase.CreateDatabase(stmt);
873 FDatabase.Connected := false;
874 ExtractUserInfo;
875 FDatabase.Connected := true;
876 Result := true;
877 Exit;
878 end;
879
880 {process connect statement}
881 RegexObj.Expression := '^ *CONNECT +.*(\' + Terminator + '|)';
882 if RegexObj.Exec(stmt) then
883 begin
884 ExtractConnectInfo;
885 FDatabase.Connected := false;
886 FDatabase.Connected := true;
887 Result := true;
888 Exit;
889 end;
890
891 {Process Drop Database}
892 RegexObj.Expression := '^ *DROP +DATABASE *(\' + Terminator + '|)';
893 if RegexObj.Exec(stmt) then
894 begin
895 FDatabase.DropDatabase;
896 Result := true;
897 Exit;
898 end;
899
900 {process commit statement}
901 RegexObj.Expression := '^ *COMMIT *(\' + Terminator + '|)';
902 if RegexObj.Exec(stmt) then
903 begin
904 DoCommit;
905 Result := true;
906 Exit;
907 end;
908
909 {process Reconnect statement}
910 RegexObj.Expression := '^ *RECONNECT *(\' + Terminator + '|)';
911 if RegexObj.Exec(stmt) then
912 begin
913 DoReconnect;
914 Result := true;
915 Exit;
916 end;
917
918
919 {Process Set Term}
920 RegexObj.Expression := '^ *SET +TERM +(.) *(\' + Terminator + '|)';
921 if RegexObj.Exec(stmt) then
922 begin
923 FSymbolStream.Terminator := RegexObj.Match[1][1];
924 Result := true;
925 Exit;
926 end;
927
928 {process Set SQL Dialect}
929 RegexObj.Expression := '^ *SET +SQL +DIALECT +([0-9]) *(\' + Terminator + '|)';
930 if RegexObj.Exec(stmt) then
931 begin
932 n := StrToInt(RegexObj.Match[1]);
933 if Database.SQLDialect <> n then
934 begin
935 Database.SQLDialect := n;
936 if Database.Connected then
937 DoReconnect;
938 end;
939 Result := true;
940 Exit;
941 end;
942
943 {Process Remaining Set statements}
944 RegexObj.Expression := '^ *SET +([A-Z]+)( +[A-Z0-9]+|) *(\' + Terminator + '|)';
945 if RegexObj.Exec(stmt) then
946 begin
947 command := AnsiUpperCase(RegexObj.Match[1]);
948 param := trim(RegexObj.Match[2]);
949 if command = 'AUTODDL' then
950 AutoDDL := ((RegexObj.MatchLen[2] = 0) and not AutoDDL) or
951 (RegexObj.MatchLen[2] > 0) and Toggle(param)
952 else
953 if command = 'BAIL' then
954 StopOnFirstError := ((RegexObj.MatchLen[2] = 0) and not StopOnFirstError) or
955 (RegexObj.MatchLen[2] > 0) and Toggle(param)
956 else
957 if command = 'ECHO' then
958 Echo := ((RegexObj.MatchLen[2] = 0) and not Echo) or
959 (RegexObj.MatchLen[2] > 0) and Toggle(param)
960 else
961 if command = 'COUNT' then
962 ShowAffectedRows := ((RegexObj.MatchLen[2] = 0) and not ShowAffectedRows) or
963 (RegexObj.MatchLen[2] > 0) and Toggle(param)
964 else
965 if command = 'STATS' then
966 ShowPerformanceStats := ((RegexObj.MatchLen[2] = 0) and not FShowPerformanceStats) or
967 (RegexObj.MatchLen[2] > 0) and Toggle(param)
968 else
969 if command = 'NAMES' then
970 begin
971 if Database.Attachment.CharSetName2CharSetID(param,charsetid) then
972 begin
973 DBConnected := Database.Connected;
974 LoginPrompt := Database.LoginPrompt;
975 Database.LoginPrompt := false;
976 Database.Connected := false;
977 Database.Params.Values['lc_ctype'] := param;
978 Database.Connected := DBConnected;
979 Database.LoginPrompt := LoginPrompt;
980 end
981 else
982 raise Exception.CreateFmt(sInvalidCharacterSet, [param,stmt]);
983 end
984 else
985 begin
986 if assigned(DataOutputFormatter) then
987 DataOutputFormatter.SetCommand(command,param,stmt,Result);
988 if not Result and assigned(OnSetStatement) then
989 OnSetStatement(self,command,param,stmt,Result)
990 else
991 raise Exception.CreateFmt(sInvalidSetStatement, [command,stmt]);
992 Exit;
993 end;
994 Result := true;
995 Exit;
996 end;
997
998 finally
999 RegexObj.Free;
1000 end;
1001 end;
1002
1003 procedure TCustomIBXScript.SetTransaction(AValue: TIBTransaction);
1004 begin
1005 if FTransaction = AValue then Exit;
1006 FTransaction := AValue;
1007 FIBXMLProcessor.Transaction := AValue;
1008 end;
1009
1010 constructor TCustomIBXScript.Create(aOwner: TComponent);
1011 begin
1012 inherited Create(aOwner);
1013 FStopOnFirstError := true;
1014 FEcho := true;
1015 FAutoDDL := true;
1016 FISQL := TIBSQL.Create(self);
1017 FISQL.ParamCheck := true;
1018 FIBXMLProcessor := TIBXMLProcessor.Create;
1019 FIBSQLProcessor := TIBSQLProcessor.Create(FIBXMLProcessor);
1020 FInternalTransaction := TIBTransaction.Create(self);
1021 FInternalTransaction.Params.Clear;
1022 FInternalTransaction.Params.Add('concurrency');
1023 FInternalTransaction.Params.Add('wait');
1024 end;
1025
1026 destructor TCustomIBXScript.Destroy;
1027 begin
1028 if FIBSQLProcessor <> nil then FIBSQLProcessor.Free;
1029 if FIBXMLProcessor <> nil then FIBXMLProcessor.Free;
1030 if FSymbolStream <> nil then FSymbolStream.Free;
1031 if FISQL <> nil then FISQL.Free;
1032 if FInternalTransaction <> nil then FInternalTransaction.Free;
1033 inherited Destroy;
1034 end;
1035
1036 procedure TCustomIBXScript.DefaultSelectSQLHandler(aSQLText: string);
1037 begin
1038 if assigned(DataOutputFormatter) then
1039 DataOutputFormatter.DataOut(aSQLText,@Add2Log)
1040 else
1041 FSymbolStream.ShowError(sNoSelectSQL,[nil]);
1042 end;
1043
1044 { TIBSQLProcessor }
1045
1046 procedure TIBSQLProcessor.AddToSQL(const Symbol: string);
1047 begin
1048 FSQLText := FSQLText + Symbol;
1049 // writeln('SQL = ',FSQLText);
1050 end;
1051
1052 procedure TIBSQLProcessor.SetState(AState: TSQLStates);
1053 begin
1054 if FStackIndex > 16 then
1055 FSymbolStream.ShowError(sStackOverFlow,[nil]);
1056 FStack[FStackIndex] := FState;
1057 Inc(FStackIndex);
1058 FState := AState
1059 end;
1060
1061 function TIBSQLProcessor.PopState: TSQLStates;
1062 begin
1063 if FStackIndex = 0 then
1064 FSymbolStream.ShowError(sStackUnderflow,[nil]);
1065 Dec(FStackIndex);
1066 Result := FStack[FStackIndex]
1067 end;
1068
1069 constructor TIBSQLProcessor.Create(XMLProcessor: TIBXMLProcessor);
1070 begin
1071 inherited Create;
1072 FXMLProcessor := XMLProcessor;
1073 end;
1074
1075 function TIBSQLProcessor.GetNextStatement(SymbolStream: TSymbolStream;
1076 var stmt: string): boolean;
1077 var Symbol: TSQLSymbol;
1078 NonSpace: boolean;
1079 Done: boolean;
1080 begin
1081 FSQLText := '';
1082 FState := stInit;
1083 FHasBegin := false;
1084 FSymbolStream := SymbolStream;
1085 FXMLProcessor.NextStatement;
1086 SymbolStream.NextStatement;
1087
1088 Result := true;
1089 Done := false;
1090 NonSpace := false;
1091 while not Done do
1092 with SymbolStream do
1093 begin
1094 if FState = stError then
1095 ShowError(sErrorState,[nil]);
1096 Symbol := GetSymbol;
1097 // writeln('Symbol = ',Symbol,' Value = ',SymbolValue);
1098 if not (Symbol in [' ',sqEOL]) then
1099 NonSpace := true;
1100
1101 case Symbol of
1102 sqTag:
1103 begin
1104 if FState in [stInSQL,stNested] then
1105 AddToSQL(FXMLProcessor.AnalyseXML(SymbolStream));
1106 end;
1107
1108 sqTerminator:
1109 case FState of
1110 stInit: {ignore empty statement};
1111
1112 stInSQL:
1113 Done := true;
1114
1115 stNested:
1116 AddToSQL(Terminator);
1117
1118 stInDeclaration:
1119 begin
1120 FState := PopState;
1121 AddToSQL(Terminator);
1122 end;
1123
1124 else
1125 ShowError(sTerminatorUnknownState,[FState]);
1126 end;
1127
1128 ';':
1129 begin
1130 if FState = stInDeclaration then
1131 FState := PopState;
1132 AddToSQL(';');
1133 end;
1134
1135 '*':
1136 begin
1137 AddToSQL('*');
1138 if FState = stInit then
1139 FState := stInSQL
1140 end;
1141
1142 '/':
1143 begin
1144 AddToSQL('/');
1145 if FState = stInit then
1146 FState := stInSQL
1147 end;
1148
1149 sqComment,
1150 sqQuotedString,
1151 sqDoubleQuotedString:
1152 if FState <> stInit then
1153 AddToSQL(SymbolValue);
1154
1155 sqCommentLine:
1156 if FState <> stInit then
1157 AddToSQL(SymbolValue + LineEnding);
1158
1159 sqEnd:
1160 begin
1161 AddToSQL(SymbolValue);
1162 case FState of
1163 stNested:
1164 begin
1165 if FNested = 0 then
1166 begin
1167 FState := PopState;
1168 if not FInCase then
1169 begin
1170 FState := stInit;
1171 Done := true;
1172 end
1173 else
1174 FInCase := false;
1175 end
1176 else
1177 Dec(FNested)
1178 end;
1179 {Otherwise ignore}
1180 end
1181 end;
1182
1183 sqBegin:
1184 begin
1185 FHasBegin := true;
1186 AddToSQL(SymbolValue);
1187 case FState of
1188 stNested:
1189 Inc(FNested);
1190
1191 stInSQL,
1192 stInit:
1193 SetState(stNested);
1194 end
1195 end;
1196
1197 sqCase:
1198 begin
1199 AddToSQL(SymbolValue);
1200 case FState of
1201 stNested:
1202 Inc(FNested);
1203
1204 stInSQL,
1205 stInit:
1206 begin
1207 FInCase := true;
1208 SetState(stNested);
1209 end;
1210 end
1211 end;
1212
1213 sqDeclare:
1214 begin
1215 AddToSQL(SymbolValue);
1216 if FState in [stInit,stInSQL] then
1217 SetState(stInDeclaration)
1218 end;
1219
1220 sqString:
1221 begin
1222 AddToSQL(SymbolValue);
1223 if FState = stInit then
1224 FState := stInSQL
1225 end;
1226
1227 sqEOL:
1228 begin
1229 case FState of
1230 stInit:
1231 {Do nothing};
1232 else
1233 if NonSpace then AddToSQL(LineEnding);
1234 end;
1235 end;
1236
1237 sqEOF:
1238 begin
1239 Done := true;
1240 Result := trim(FSQLText) <> '';
1241 end
1242 else
1243 if FState <> stInit then
1244 AddToSQL(Symbol);
1245 end
1246 end;
1247 stmt := FSQLText;
1248 // writeln('stmt = ',stmt);
1249 end;
1250
1251 { TIBXMLProcessor }
1252
1253 procedure TIBXMLProcessor.EndXMLTag(xmltag: TXMLTag);
1254 begin
1255 if FXMLTagIndex = 0 then
1256 FSymbolStream.ShowError(sXMLStackUnderflow,[nil]);
1257 if xmltag <> FXMLTagStack[FXMLTagIndex] then
1258 FSymbolStream.ShowError(sInvalidEndTag,[FSymbolStream.SymbolValue]);
1259
1260 case FXMLTagStack[FXMLTagIndex] of
1261 xtBlob:
1262 FBlobData[FCurrentBlob].BlobIntf.Close;
1263
1264 xtArray:
1265 FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
1266
1267 xtElt:
1268 Dec(FArrayData[FCurrentArray].CurrentRow);
1269 end;
1270 Dec(FXMLTagIndex);
1271 end;
1272
1273 procedure TIBXMLProcessor.EnterTag;
1274 var aCharSetID: integer;
1275 begin
1276 case FXMLTagStack[FXMLTagIndex] of
1277 xtBlob:
1278 begin
1279 Database.Connected := true;
1280 Transaction.Active := true;
1281 FBlobData[FCurrentBlob].BlobIntf := Database.Attachment.CreateBlob(
1282 Transaction.TransactionIntf,FBlobData[FCurrentBlob].SubType);
1283 end;
1284
1285 xtArray:
1286 with FArrayData[FCurrentArray] do
1287 begin
1288 Database.Connected := true;
1289 Transaction.Active := true;
1290 Database.Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
1291 SetLength(Index,dim);
1292 ArrayIntf := Database.Attachment.CreateArray(
1293 Transaction.TransactionIntf,
1294 Database.Attachment.CreateArrayMetaData(SQLType,
1295 relationName,columnName,Scale,Size,
1296 aCharSetID,dim,bounds)
1297 );
1298 end;
1299 end;
1300 end;
1301
1302 function TIBXMLProcessor.GetArrayData(index: integer): TArrayData;
1303 begin
1304 if (index < 0) or (index > ArrayDataCount) then
1305 FSymbolStream.ShowError(sArrayIndexError,[index]);
1306 Result := FArrayData[index];
1307 end;
1308
1309 function TIBXMLProcessor.GetArrayDataCount: integer;
1310 begin
1311 Result := Length(FArrayData);
1312 end;
1313
1314 function TIBXMLProcessor.GetBlobData(index: integer): TBlobData;
1315 begin
1316 if (index < 0) or (index > BlobDataCount) then
1317 FSymbolStream.ShowError(sBlobIndexError,[index]);
1318 Result := FBlobData[index];
1319 end;
1320
1321 function TIBXMLProcessor.GetBlobDataCount: integer;
1322 begin
1323 Result := Length(FBlobData);
1324 end;
1325
1326 procedure TIBXMLProcessor.ProcessTagValue(tagValue: string);
1327
1328 function nibble(hex: char): byte;
1329 begin
1330 case hex of
1331 '0': Result := 0;
1332 '1': Result := 1;
1333 '2': Result := 2;
1334 '3': Result := 3;
1335 '4': Result := 4;
1336 '5': Result := 5;
1337 '6': Result := 6;
1338 '7': Result := 7;
1339 '8': Result := 8;
1340 '9': Result := 9;
1341 'a','A': Result := 10;
1342 'b','B': Result := 11;
1343 'c','C': Result := 12;
1344 'd','D': Result := 13;
1345 'e','E': Result := 14;
1346 'f','F': Result := 15;
1347 end;
1348 end;
1349
1350 procedure RemoveWhiteSpace(var hexData: string);
1351 var i: integer;
1352 begin
1353 {Remove White Space}
1354 i := 1;
1355 while i <= length(hexData) do
1356 begin
1357 case hexData[i] of
1358 ' ',#9,#10,#13:
1359 begin
1360 if i < Length(hexData) then
1361 Move(hexData[i+1],hexData[i],Length(hexData)-i);
1362 SetLength(hexData,Length(hexData)-1);
1363 end;
1364 else
1365 Inc(i);
1366 end;
1367 end;
1368 end;
1369
1370 procedure WriteToBlob(hexData: string);
1371 var i,j : integer;
1372 blength: integer;
1373 P: PChar;
1374 begin
1375 RemoveWhiteSpace(hexData);
1376 if odd(length(hexData)) then
1377 FSymbolStream.ShowError(sBinaryBlockMustbeEven,[nil]);
1378 blength := Length(hexData) div 2;
1379 IBAlloc(FBlobBuffer,0,blength);
1380 j := 1;
1381 P := FBlobBuffer;
1382 for i := 1 to blength do
1383 begin
1384 P^ := char((nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]));
1385 Inc(j,2);
1386 Inc(P);
1387 end;
1388 FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
1389 end;
1390
1391 begin
1392 if tagValue = '' then Exit;
1393 case FXMLTagStack[FXMLTagIndex] of
1394 xtBlob:
1395 WriteToBlob(tagValue);
1396
1397 xtElt:
1398 with FArrayData[FCurrentArray] do
1399 ArrayIntf.SetAsString(index,tagValue);
1400
1401 end;
1402 end;
1403
1404 procedure TIBXMLProcessor.StartXMLTag(xmltag: TXMLTag);
1405 begin
1406 if FXMLTagIndex > 19 then
1407 FSymbolStream.ShowError(sXMLStackOverFlow,[nil]);
1408 Inc(FXMLTagIndex);
1409 FXMLTagStack[FXMLTagIndex] := xmltag;
1410 case xmltag of
1411 xtBlob:
1412 begin
1413 Inc(FCurrentBlob);
1414 SetLength(FBlobData,FCurrentBlob+1);
1415 FBlobData[FCurrentBlob].BlobIntf := nil;
1416 FBlobData[FCurrentBlob].SubType := 0;
1417 end;
1418
1419 xtArray:
1420 begin
1421 Inc(FCurrentArray);
1422 SetLength(FArrayData,FCurrentArray+1);
1423 with FArrayData[FCurrentArray] do
1424 begin
1425 ArrayIntf := nil;
1426 SQLType := 0;
1427 dim := 0;
1428 Size := 0;
1429 Scale := 0;
1430 CharSet := 'NONE';
1431 SetLength(Index,0);
1432 CurrentRow := -1;
1433 end;
1434 end;
1435
1436 xtElt:
1437 with FArrayData[FCurrentArray] do
1438 Inc(CurrentRow);
1439
1440 end;
1441 end;
1442
1443 procedure TIBXMLProcessor.ProcessAttributeValue(attrValue: string);
1444 begin
1445 case FXMLTagStack[FXMLTagIndex] of
1446 xtBlob:
1447 if FAttributeName = 'subtype' then
1448 FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
1449 else
1450 FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1451
1452 xtArray:
1453 if FAttributeName = 'sqltype' then
1454 FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
1455 else
1456 if FAttributeName = 'relation_name' then
1457 FArrayData[FCurrentArray].relationName := attrValue
1458 else
1459 if FAttributeName = 'column_name' then
1460 FArrayData[FCurrentArray].columnName := attrValue
1461 else
1462 if FAttributeName = 'dim' then
1463 FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
1464 else
1465 if FAttributeName = 'length' then
1466 FArrayData[FCurrentArray].Size := StrToInt(attrValue)
1467 else
1468 if FAttributeName = 'scale' then
1469 FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
1470 else
1471 if FAttributeName = 'charset' then
1472 FArrayData[FCurrentArray].CharSet := attrValue
1473 else
1474 if FAttributeName = 'bounds' then
1475 ProcessBoundsList(attrValue)
1476 else
1477 FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1478
1479 xtElt:
1480 if FAttributeName = 'ix' then
1481 with FArrayData[FCurrentArray] do
1482 Index[CurrentRow] := StrToInt(attrValue)
1483 else
1484 FSymbolStream.ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
1485 end;
1486 end;
1487
1488 procedure TIBXMLProcessor.ProcessBoundsList(boundsList: string);
1489 var list: TStringList;
1490 i,j: integer;
1491 begin
1492 list := TStringList.Create;
1493 try
1494 list.Delimiter := ',';
1495 list.DelimitedText := boundsList;
1496 with FArrayData[FCurrentArray] do
1497 begin
1498 if dim <> list.Count then
1499 FSymbolStream.ShowError(sInvalidBoundsList,[boundsList]);
1500 SetLength(bounds,dim);
1501 for i := 0 to list.Count - 1 do
1502 begin
1503 j := Pos(':',list[i]);
1504 if j = 0 then
1505 raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
1506 bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
1507 bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
1508 end;
1509 end;
1510 finally
1511 list.Free;
1512 end;
1513 end;
1514
1515 constructor TIBXMLProcessor.Create;
1516 begin
1517 inherited Create;
1518 NextStatement;
1519 end;
1520
1521 destructor TIBXMLProcessor.Destroy;
1522 begin
1523 FreeMem(FBlobBuffer);
1524 inherited Destroy;
1525 end;
1526
1527 function TIBXMLProcessor.AnalyseXML(SymbolStream: TSymbolStream): string;
1528 var Symbol: TSQLSymbol;
1529 Done: boolean;
1530 XMLString: string;
1531 begin
1532 Result := '';
1533 XMLString := '';
1534 Done := false;
1535 FState := stInTag;
1536 FSymbolStream := SymbolStream;
1537 with SymbolStream do
1538 begin
1539 StartXMLTag(XMLTag);
1540 while not Done do
1541 with SymbolStream do
1542 begin
1543 Symbol := GetSymbol;
1544
1545 case Symbol of
1546 sqEOL:
1547 case FState of
1548 stQuotedAttributeValue,
1549 stTagged:
1550 XMLString += LineEnding;
1551 end;
1552
1553 ' ',sqTab:
1554 case FState of
1555 stQuotedAttributeValue,
1556 stTagged:
1557 XMLString += ' ';
1558 end;
1559
1560 ';':
1561 case FState of
1562 stQuotedAttributeValue,
1563 stTagged:
1564 XMLString += ';';
1565 else
1566 ShowError(sXMLError,[Symbol]);
1567 end;
1568
1569 '''':
1570 case FState of
1571 stQuotedAttributeValue,
1572 stTagged:
1573 XMLString += '''';
1574 else
1575 ShowError(sXMLError,[Symbol]);
1576 end;
1577
1578 '*':
1579 case FState of
1580 stQuotedAttributeValue,
1581 stTagged:
1582 XMLString += '*';
1583 else
1584 ShowError(sXMLError,[Symbol]);
1585 end;
1586
1587 '/':
1588 case FState of
1589 stQuotedAttributeValue,
1590 stTagged:
1591 XMLString += '/';
1592 else
1593 ShowError(sXMLError,[Symbol]);
1594 end;
1595
1596 '>':
1597 case FState of
1598 stEndTag:
1599 case XMLTag of
1600 xtBlob:
1601 begin
1602 Result := ':' + Format(ibx_blob+'%d',[FCurrentBlob]);
1603 Done := true;
1604 end;
1605 xtArray:
1606 begin
1607 Result := ':' + Format(ibx_array+'%d',[FCurrentArray]);
1608 Done := true;
1609 end;
1610 else
1611 FState := stTagged;
1612 end;
1613
1614 stInTag:
1615 begin
1616 XMLString := '';
1617 FState := stTagged;
1618 EnterTag;
1619 end;
1620
1621 stQuotedAttributeValue,
1622 stTagged:
1623 XMLString += '>';
1624
1625 else
1626 ShowError(sXMLError,[Symbol]);
1627 end;
1628
1629 sqTag:
1630 if FState = stTagged then
1631 begin
1632 FState := stInTag;
1633 StartXMLTag(XMLTag)
1634 end
1635 else
1636 ShowError(sXMLError,[Symbol]);
1637
1638 sqEndTag:
1639 if FState = stTagged then
1640 begin
1641 ProcessTagValue(XMLString);
1642 EndXMLTag(XMLTag);
1643 FState := stEndTag;
1644 end
1645 else
1646 ShowError(sXMLError,[Symbol]);
1647
1648 '=':
1649 case FState of
1650 stAttribute:
1651 FState := stAttributeValue;
1652
1653 stQuotedAttributeValue,
1654 stTagged:
1655 XMLString += '=';
1656
1657 else
1658 ShowError(sXMLError,[Symbol]);
1659 end;
1660
1661 '"':
1662 case FState of
1663 stAttributeValue:
1664 begin
1665 XMLString := '';
1666 FState := stQuotedAttributeValue;
1667 end;
1668
1669 stQuotedAttributeValue:
1670 begin
1671 ProcessAttributeValue(XMLString);
1672 FState := stInTag;
1673 end;
1674
1675 stTagged:
1676 XMLString += '"';
1677
1678 else
1679 ShowError(sXMLError,[Symbol]);
1680 end;
1681
1682 sqString:
1683 case FState of
1684 stInTag: {attribute name}
1685 begin
1686 FAttributeName := SymbolValue;
1687 FState := stAttribute;
1688 end;
1689
1690 stAttributeValue:
1691 begin
1692 ProcessAttributeValue(FString);
1693 FState := stInTag;
1694 end;
1695
1696 stQuotedAttributeValue,
1697 stTagged:
1698 XMLString += SymbolValue;
1699
1700 else
1701 ShowError(sXMLError,[Symbol]);
1702 end;
1703 else
1704 ShowError(sXMLError,[Symbol]);
1705 end
1706 end;
1707 end;
1708 end;
1709
1710 procedure TIBXMLProcessor.NextStatement;
1711 begin
1712 FXMLTagIndex := 0;
1713 SetLength(FBlobData,0);
1714 FCurrentBlob := -1;
1715 SetLength(FArrayData,0);
1716 FCurrentArray := -1;
1717 end;
1718
1719 class function TIBXMLProcessor.FormatBlob(Field: ISQLData): string;
1720 var TextOut: TStrings;
1721 begin
1722 TextOut := TStringList.Create;
1723 try
1724 TextOut.Add(Format('<blob subtype="%d">',[Field.getSubtype]));
1725 StringToHex(Field.AsString,TextOut,BlobLineLength);
1726 TextOut.Add('</blob>');
1727 Result := TextOut.Text;
1728 finally
1729 TextOut.Free;
1730 end;
1731 end;
1732
1733 class function TIBXMLProcessor.FormatArray(Database: TIBDatabase; ar: IArray
1734 ): string;
1735 var index: array of integer;
1736 TextOut: TStrings;
1737
1738 procedure AddElements(dim: integer; indent:string = ' ');
1739 var i: integer;
1740 recurse: boolean;
1741 begin
1742 SetLength(index,dim+1);
1743 recurse := dim < ar.GetDimensions - 1;
1744 with ar.GetBounds[dim] do
1745 for i := LowerBound to UpperBound do
1746 begin
1747 index[dim] := i;
1748 if recurse then
1749 begin
1750 TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
1751 AddElements(dim+1,indent + ' ');
1752 TextOut.Add('</elt>');
1753 end
1754 else
1755 if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
1756 (ar.GetCharSetID = 1) then
1757 TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
1758 else
1759 TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
1760 end;
1761 end;
1762
1763 var
1764 s: string;
1765 bounds: TArrayBounds;
1766 i: integer;
1767 boundsList: string;
1768 begin
1769 TextOut := TStringList.Create;
1770 try
1771 s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
1772 [ar.GetDimensions,ar.GetSQLType,ar.GetSize,
1773 ar.GetTableName,ar.GetColumnName]);
1774 case ar.GetSQLType of
1775 SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
1776 s += Format(' scale = "%d"',[ ar.GetScale]);
1777 SQL_TEXT,
1778 SQL_VARYING:
1779 s += Format(' charset = "%s"',[Database.Attachment.GetCharsetName(ar.GetCharSetID)]);
1780 end;
1781 bounds := ar.GetBounds;
1782 boundsList := '';
1783 for i := 0 to length(bounds) - 1 do
1784 begin
1785 if i <> 0 then boundsList += ',';
1786 boundsList += Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
1787 end;
1788 s += Format(' bounds="%s"',[boundsList]);
1789 s += '>';
1790 TextOut.Add(s);
1791
1792 SetLength(index,0);
1793 AddElements(0);
1794 TextOut.Add('</array>');
1795 Result := TextOut.Text;
1796 finally
1797 TextOut.Free;
1798 end;
1799 end;
1800
1801 { TInteractiveSymbolStream }
1802
1803 function TInteractiveSymbolStream.GetErrorPrefix: string;
1804 begin
1805 Result := '';
1806 end;
1807
1808 function TInteractiveSymbolStream.GetNextLine(var Line: string): boolean;
1809 begin
1810 if FNextStatement then
1811 write(FPrompt)
1812 else
1813 write(FContinuePrompt);
1814 Result := not EOF;
1815 if Result then
1816 readln(Line);
1817 end;
1818
1819 constructor TInteractiveSymbolStream.Create(aPrompt: string; aContinue: string);
1820 begin
1821 inherited Create;
1822 FPrompt := aPrompt;
1823 FContinuePrompt := aContinue;
1824 end;
1825
1826 function TInteractiveSymbolStream.GetSymbol: TSQLSymbol;
1827 begin
1828 if Terminated then
1829 Result := sqEOF
1830 else
1831 Result := inherited GetSymbol;
1832 end;
1833
1834 { TBatchSymbolStream }
1835
1836 function TBatchSymbolStream.GetErrorPrefix: string;
1837 begin
1838 Result := Format(sOnLineError,[FLineIndex,FIndex]);
1839 end;
1840
1841 function TBatchSymbolStream.GetNextLine(var Line: string): boolean;
1842 begin
1843 Result := FLineIndex < FLines.Count;
1844 if Result then
1845 begin
1846 Line := FLines[FLineIndex];
1847 // writeln('Next Line = ',Line);
1848 Inc(FLineIndex);
1849 if assigned(OnProgressEvent) then
1850 OnProgressEvent(self,false,1);
1851 end;
1852 end;
1853
1854 constructor TBatchSymbolStream.Create;
1855 begin
1856 inherited Create;
1857 FLines := TStringList.Create;
1858 end;
1859
1860 destructor TBatchSymbolStream.Destroy;
1861 begin
1862 if assigned(FLines) then FLines.Free;
1863 inherited Destroy;
1864 end;
1865
1866 procedure TBatchSymbolStream.SetStreamSource(Lines: TStrings);
1867 begin
1868 FLineIndex := 0;
1869 FLines.Assign(Lines);
1870 if assigned(OnProgressEvent) then
1871 OnProgressEvent(self,true,FLines.Count);
1872 end;
1873
1874 procedure TBatchSymbolStream.SetStreamSource(S: TStream);
1875 begin
1876 FLineIndex := 0;
1877 FLines.LoadFromStream(S);
1878 if assigned(OnProgressEvent) then
1879 OnProgressEvent(self,true,FLines.Count);
1880 end;
1881
1882 procedure TBatchSymbolStream.SetStreamSource(FileName: string);
1883 begin
1884 FLineIndex := 0;
1885 FLines.LoadFromFile(FileName);
1886 if assigned(OnProgressEvent) then
1887 OnProgressEvent(self,true,FLines.Count);
1888 end;
1889
1890 { TSymbolStream }
1891
1892 function TSymbolStream.GetNextSymbol(C: char): TSQLSymbol;
1893 begin
1894 Result := sqNone;
1895 if C = FTerminator then
1896 Result := sqTerminator
1897 else
1898 case C of
1899 #0..#8,#10..#31,' ':
1900 Result := ' ';
1901
1902 #9,';','"','''','/','-',
1903 '*','=','>','<',',':
1904 Result := C;
1905 else
1906 begin
1907 Result := sqString;
1908 FLastChar := C
1909 end
1910 end;
1911 end;
1912
1913 function TSymbolStream.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
1914 var i: integer;
1915 begin
1916 Result := false;
1917 for i := 0 to Length(XMLTagDefs) - 1 do
1918 if XMLTagDefs[i].TagValue = tag then
1919 begin
1920 xmlTag := XMLTagDefs[i].XMLTag;
1921 Result := true;
1922 break;
1923 end;
1924 end;
1925
1926 constructor TSymbolStream.Create;
1927 begin
1928 inherited;
1929 FTerminator := DefaultTerminator;
1930 NextStatement;
1931 end;
1932
1933 procedure TSymbolStream.ShowError(msg: string; params: array of const);
1934 begin
1935 raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
1936 end;
1937
1938 function TSymbolStream.GetSymbol: TSQLSymbol;
1939 var
1940 DelimitedText: string;
1941 CurState: (gsNone,gsInComment,gsInSingleQuotes,gsInDoubleQuotes);
1942 begin
1943 Result := sqNone;
1944 CurState := gsNone;
1945 DelimitedText := '';
1946 if FNextSymbol <> sqNone then
1947 begin
1948 Result := FNextSymbol;
1949 if Result = sqString then
1950 FString := FLastChar
1951 else
1952 FString := '';
1953 FNextSymbol := sqNone
1954 end;
1955
1956 while FNextSymbol = sqNone do {find the next symbol}
1957 begin
1958 if FIndex > Length(FLine) then
1959 begin
1960 FNextSymbol := sqEOL;
1961 FIndex := 0;
1962 end
1963 else
1964 begin
1965 if FIndex = 0 then
1966 begin
1967 if not GetNextLine(FLine) then
1968 begin
1969 Result := sqEOF;
1970 FNextSymbol := sqNone;
1971 Exit;
1972 end;
1973 FIndex := 1;
1974 FNextStatement := false;
1975 if assigned(OnNextLine) then
1976 OnNextLine(self,FLine);
1977 if CurState <> gsNone then
1978 DelimitedText += LineEnding;
1979 if Length(FLine) = 0 then
1980 continue;
1981 end;
1982 if CurState <> gsNone then
1983 DelimitedText += FLine[FIndex];
1984 FNextSymbol := GetNextSymbol(FLine[FIndex]);
1985 Inc(FIndex);
1986 end;
1987
1988 case CurState of
1989 gsNone:
1990 begin
1991 {combine if possible}
1992 case Result of
1993 sqNone:
1994 begin
1995 Result := FNextSymbol;
1996 if FNextSymbol = sqString then
1997 FString := FLastChar;
1998 FNextSymbol := sqNone
1999 end;
2000
2001 '/':
2002 if FXMLMode > 0 then
2003 break
2004 else
2005 if FNextSymbol = '*' then
2006 begin
2007 CurState := gsInComment;
2008 DelimitedText := '/*';
2009 Result := sqNone;
2010 FNextSymbol := sqNone
2011 end
2012 else
2013 if FNextSymbol = '/' then
2014 begin
2015 FString := '/*' + system.copy(FLine,FIndex,length(FLine)- FIndex + 1) + ' */';
2016 Result := sqCommentLine;
2017 FIndex := 0;
2018 FNextSymbol := sqNone
2019 end;
2020
2021 '-':
2022 if FXMLMode > 0 then
2023 break
2024 else
2025 if FNextSymbol = '-' then
2026 begin
2027 FString := '--' + system.copy(FLine,FIndex,length(FLine)- FIndex + 1) ;
2028 Result := sqCommentLine;
2029 FIndex := 0;
2030 FNextSymbol := sqNone
2031 end;
2032
2033 '<':
2034 if (FXMLMode > 0) and (FNextSymbol = '/') then
2035 begin
2036 Result := sqEndTag;
2037 FString := '';
2038 FNextSymbol := sqNone
2039 end
2040 else
2041 if FNextSymbol = sqString then
2042 begin
2043 Result := sqTag;
2044 FString := FLastChar;
2045 FNextSymbol := sqNone
2046 end;
2047
2048 '''':
2049 if FXMLMode > 0 then
2050 break
2051 else
2052 if FNextSymbol = '''' then
2053 begin
2054 Result := sqQuotedString;
2055 FString := '''''';
2056 FNextSymbol := sqNone
2057 end
2058 else
2059 begin
2060 CurState := gsInSingleQuotes;
2061 DelimitedText := '''';
2062 if FNextSymbol = sqEOL then
2063 DelimitedText += LineEnding
2064 else
2065 DelimitedText += FLine[FIndex-1];
2066 Result := sqNone;
2067 FNextSymbol := sqNone
2068 end;
2069
2070 '"':
2071 if FXMLMode > 0 then
2072 break
2073 else
2074 begin
2075 CurState := gsInDoubleQuotes;
2076 DelimitedText := '"';
2077 if FNextSymbol = sqEOL then
2078 DelimitedText += LineEnding
2079 else
2080 DelimitedText += FLine[FIndex-1];
2081 Result := sqNone;
2082 FNextSymbol := sqNone
2083 end;
2084
2085 sqTag,
2086 sqEndTag,
2087 sqString:
2088 if FNextSymbol = sqString then
2089 begin
2090 FString := FString + FLastChar;
2091 FNextSymbol := sqNone
2092 end;
2093 end
2094 end;
2095
2096 {Check for state exit condition}
2097 gsInSingleQuotes:
2098 if Result = '''' then
2099 begin
2100 CurState := gsNone;
2101 if FNextSymbol = sqEOL then
2102 FString := DelimitedText
2103 else
2104 FString := system.copy(DelimitedText,1,Length(DelimitedText)-1);
2105 Result := sqQuotedString;
2106 end;
2107
2108 gsInDoubleQuotes:
2109 if Result = '"' then
2110 begin
2111 CurState := gsNone;
2112 if FNextSymbol = sqEOL then
2113 FString := DelimitedText
2114 else
2115 FString := system.copy(DelimitedText,1,Length(DelimitedText)-1);
2116 Result := sqDoubleQuotedString;
2117 end;
2118
2119 gsInComment:
2120 if (Result = '*') and (FNextSymbol = '/') then
2121 begin
2122 CurState := gsNone;
2123 FString := DelimitedText;
2124 Result := sqComment;
2125 FNextSymbol := sqNone
2126 end;
2127
2128 end;
2129
2130 if (CurState <> gsNone) and (FNextSymbol <> sqNone) then
2131 begin
2132 Result := FNextSymbol;
2133 FNextSymbol := sqNone;
2134 end;
2135 end;
2136
2137 if (Result = sqTag) and (FNextSymbol <> sqNone) then
2138 begin
2139 if FindTag(FString,FXMLTag) then
2140 Inc(FXMLMode)
2141 else
2142 Result := sqString;
2143 end
2144 else
2145 if (Result = sqEndTag) and (FNextSymbol <> sqNone) then
2146 begin
2147 if FindTag(FString,FXMLTag) then
2148 Dec(FXMLMode)
2149 else
2150 Result := sqString;
2151 end;
2152
2153 if (FXMLMode = 0) and (Result = sqString) and (FString <> '') then
2154 begin
2155 if CompareText(FString,'begin') = 0 then
2156 Result := sqBegin
2157 else
2158 if CompareText(FString,'end') = 0 then
2159 Result := sqEnd
2160 else
2161 if CompareText(FString,'declare') = 0 then
2162 Result := sqDeclare
2163 else
2164 if CompareText(FString,'case') = 0 then
2165 Result := sqCase
2166 end;
2167 // writeln(Result,',',FString);
2168 end;
2169
2170 procedure TSymbolStream.NextStatement;
2171 begin
2172 FXMLTag := xtNone;
2173 FNextStatement := true;
2174 end;
2175
2176 end.
2177