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