ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/ibxscript.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 60481 byte(s)
Log Message:
Fixes Merged

File Contents

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