ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/IBUtils.pas
Revision: 371
Committed: Wed Jan 5 15:21:22 2022 UTC (2 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 73711 byte(s)
Log Message: 
Beta Release 0.1

File Contents

# User Rev Content
1 tony 45 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 Inprise Corporation }
7     { }
8     { InterBase Express is based in part on the product }
9     { Free IB Components, written by Gregory H. Deatz for }
10     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11     { Free IB Components is used under license. }
12     { }
13     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     { IBX For Lazarus (Firebird Express) }
28     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29     { Portions created by MWA Software are copyright McCallum Whyman }
30     { Associates Ltd 2011 }
31     { }
32     {************************************************************************}
33    
34     unit IBUtils;
35 tony 56 {$IFDEF MSWINDOWS}
36 tony 118 {$DEFINE WINDOWS}
37 tony 56 {$ENDIF}
38 tony 45
39     {$IFDEF FPC}
40     {$Mode Delphi}
41     {$codepage UTF8}
42     {$ENDIF}
43    
44 tony 315 { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45     { $define HASDELPHIREQEX}
46     { $IFEND}
47 tony 118
48 tony 45 interface
49    
50 tony 143 uses Classes, SysUtils, IB;
51 tony 45
52 tony 363 {$IF not defined(LineEnding)}
53     const
54     {$IFDEF WINDOWS}
55     LineEnding = #$0D#$0A;
56     {$ELSE}
57     LineEnding = #$0A;
58     {$ENDIF}
59     {$IFEND}
60    
61 tony 263 type
62     TSQLTokens = (
63    
64     {Reserved Words}
65    
66     sqltAdd,
67     sqltAdmin,
68     sqltAll,
69     sqltAlter,
70     sqltAnd,
71     sqltAny,
72     sqltAs,
73     sqltAt,
74     sqltAvg,
75     sqltBegin,
76     sqltBetween,
77     sqltBigint,
78     sqltBit_Length,
79     sqltBlob,
80     sqltBoolean,
81     sqltBoth,
82     sqltBy,
83     sqltCase,
84     sqltCast,
85     sqltChar,
86     sqltChar_Length,
87     sqltCharacter,
88     sqltCharacter_Length,
89     sqltCheck,
90     sqltClose,
91     sqltCollate,
92     sqltColumn,
93     sqltCommit,
94     sqltConnect,
95     sqltConstraint,
96     sqltCorr,
97     sqltCount,
98     sqltCovar_Pop,
99     sqltCovar_Samp,
100     sqltCreate,
101     sqltCross,
102     sqltCurrent,
103     sqltCurrent_Connection,
104     sqltCurrent_Date,
105     sqltCurrent_Role,
106     sqltCurrent_Time,
107     sqltCurrent_Timestamp,
108     sqltCurrent_Transaction,
109     sqltCurrent_User,
110     sqltCursor,
111     sqltDate,
112     sqltDay,
113     sqltDec,
114     sqltDecimal,
115     sqltDeclare,
116     sqltDefault,
117     sqltDelete,
118     sqltDeleting,
119     sqltDeterministic,
120     sqltDisconnect,
121     sqltDistinct,
122     sqltDouble,
123     sqltDrop,
124     sqltElse,
125     sqltEnd,
126     sqltEscape,
127     sqltExecute,
128     sqltExists,
129     sqltExternal,
130     sqltExtract,
131     sqltFalse,
132     sqltFetch,
133     sqltFilter,
134     sqltFloat,
135     sqltFor,
136     sqltForeign,
137     sqltFrom,
138     sqltFull,
139     sqltFunction,
140     sqltGdscode,
141     sqltGlobal,
142     sqltGrant,
143     sqltGroup,
144     sqltHaving,
145     sqltHour,
146     sqltIn,
147     sqltIndex,
148     sqltInner,
149     sqltInsensitive,
150     sqltInsert,
151     sqltInserting,
152     sqltInt,
153     sqltInteger,
154     sqltInto,
155     sqltIs,
156     sqltJoin,
157     sqltKey,
158     sqltLeading,
159     sqltLeft,
160     sqltLike,
161     sqltLong,
162     sqltLower,
163     sqltMax,
164     sqltMaximum_Segment,
165     sqltMerge,
166     sqltMin,
167     sqltMinute,
168     sqltMonth,
169     sqltNational,
170     sqltNatural,
171     sqltNchar,
172     sqltNo,
173     sqltNot,
174     sqltNull,
175     sqltNumeric,
176     sqltOctet_Length,
177     sqltOf,
178     sqltOffset,
179     sqltOn,
180     sqltOnly,
181     sqltOpen,
182     sqltOr,
183     sqltOrder,
184     sqltOuter,
185     sqltOver,
186     sqltParameter,
187     sqltPlan,
188     sqltPosition,
189     sqltPost_Event,
190     sqltPrecision,
191     sqltPrimary,
192     sqltProcedure,
193     sqltRdbDb_Key,
194     sqltRdbRecord_Version,
195     sqltReal,
196     sqltRecord_Version,
197     sqltRecreate,
198     sqltRecursive,
199     sqltReferences,
200     sqltRegr_Avgx,
201     sqltRegr_Avgy,
202     sqltRegr_Count,
203     sqltRegr_Intercept,
204     sqltRegr_R2,
205     sqltRegr_Slope,
206     sqltRegr_Sxx,
207     sqltRegr_Sxy,
208     sqltRegr_Syy,
209     sqltRelease,
210     sqltReturn,
211     sqltReturning_Values,
212     sqltReturns,
213     sqltRevoke,
214     sqltRight,
215     sqltRollback,
216     sqltRow,
217     sqltRows,
218     sqltRow_Count,
219     sqltSavepoint,
220     sqltScroll,
221     sqltSecond,
222     sqltSelect,
223     sqltSensitive,
224     sqltSet,
225     sqltSimilar,
226     sqltSmallint,
227     sqltSome,
228     sqltSqlcode,
229     sqltSqlstate,
230     sqltStart,
231     sqltStddev_Pop,
232     sqltStddev_Samp,
233     sqltSum,
234     sqltTable,
235     sqltThen,
236     sqltTime,
237     sqltTimestamp,
238     sqltTo,
239     sqltTrailing,
240     sqltTrigger,
241     sqltTrim,
242     sqltTrue,
243     sqltUnion,
244     sqltUnique,
245     sqltUnknown,
246     sqltUpdate,
247     sqltUpdating,
248     sqltUpper,
249     sqltUser,
250     sqltUsing,
251     sqltValue,
252     sqltValues,
253     sqltVar_Pop,
254     sqltVar_Samp,
255     sqltVarchar,
256     sqltVariable,
257     sqltVarying,
258     sqltView,
259     sqltWhen,
260     sqltWhere,
261     sqltWhile,
262     sqltWith,
263     sqltYear,
264    
265     {symbols}
266    
267     sqltSpace,
268     sqltSemiColon,
269     sqltPlaceholder,
270     sqltSingleQuotes,
271     sqltDoubleQuotes,
272 tony 270 sqltBackslash,
273 tony 263 sqltComma,
274     sqltPeriod,
275     sqltEquals,
276     sqltOtherCharacter,
277     sqltIdentifier,
278     sqltIdentifierInDoubleQuotes,
279     sqltNumberString,
280     sqltString,
281     sqltParam,
282     sqltQuotedParam,
283     sqltColon,
284     sqltComment,
285     sqltCommentLine,
286     sqltQuotedString,
287     sqltAsterisk,
288     sqltForwardSlash,
289     sqltOpenSquareBracket,
290     sqltCloseSquareBracket,
291     sqltOpenBracket,
292     sqltCloseBracket,
293     sqltPipe,
294 tony 287 sqltMinus,
295 tony 263 sqltConcatSymbol,
296     sqltLT,
297     sqltGT,
298     sqltCR,
299     sqltEOL,
300     sqltEOF,
301     sqltInit
302     );
303    
304     TSQLReservedWords = sqltAdd..sqltYear;
305    
306 tony 45 const
307     CRLF = #13 + #10;
308     CR = #13;
309     LF = #10;
310     TAB = #9;
311     NULL_TERMINATOR = #0;
312    
313 tony 263 {SQL Reserved words in alphabetical order}
314    
315     sqlReservedWords: array [TSQLReservedWords] of string = (
316 tony 47 'ADD',
317     'ADMIN',
318     'ALL',
319     'ALTER',
320     'AND',
321     'ANY',
322     'AS',
323     'AT',
324     'AVG',
325     'BEGIN',
326     'BETWEEN',
327     'BIGINT',
328     'BIT_LENGTH',
329     'BLOB',
330     'BOOLEAN',
331     'BOTH',
332     'BY',
333     'CASE',
334     'CAST',
335     'CHAR',
336     'CHAR_LENGTH',
337     'CHARACTER',
338     'CHARACTER_LENGTH',
339     'CHECK',
340     'CLOSE',
341     'COLLATE',
342     'COLUMN',
343     'COMMIT',
344     'CONNECT',
345     'CONSTRAINT',
346     'CORR',
347     'COUNT',
348     'COVAR_POP',
349     'COVAR_SAMP',
350     'CREATE',
351     'CROSS',
352     'CURRENT',
353     'CURRENT_CONNECTION',
354     'CURRENT_DATE',
355     'CURRENT_ROLE',
356     'CURRENT_TIME',
357     'CURRENT_TIMESTAMP',
358     'CURRENT_TRANSACTION',
359     'CURRENT_USER',
360     'CURSOR',
361     'DATE',
362     'DAY',
363     'DEC',
364     'DECIMAL',
365     'DECLARE',
366     'DEFAULT',
367     'DELETE',
368     'DELETING',
369     'DETERMINISTIC',
370     'DISCONNECT',
371     'DISTINCT',
372     'DOUBLE',
373     'DROP',
374     'ELSE',
375     'END',
376     'ESCAPE',
377     'EXECUTE',
378     'EXISTS',
379     'EXTERNAL',
380     'EXTRACT',
381     'FALSE',
382     'FETCH',
383     'FILTER',
384     'FLOAT',
385     'FOR',
386     'FOREIGN',
387     'FROM',
388     'FULL',
389     'FUNCTION',
390     'GDSCODE',
391     'GLOBAL',
392     'GRANT',
393     'GROUP',
394     'HAVING',
395     'HOUR',
396     'IN',
397     'INDEX',
398     'INNER',
399     'INSENSITIVE',
400     'INSERT',
401     'INSERTING',
402     'INT',
403     'INTEGER',
404     'INTO',
405     'IS',
406     'JOIN',
407 tony 209 'KEY',
408 tony 47 'LEADING',
409     'LEFT',
410     'LIKE',
411     'LONG',
412     'LOWER',
413     'MAX',
414     'MAXIMUM_SEGMENT',
415     'MERGE',
416     'MIN',
417     'MINUTE',
418     'MONTH',
419     'NATIONAL',
420     'NATURAL',
421     'NCHAR',
422     'NO',
423     'NOT',
424     'NULL',
425     'NUMERIC',
426     'OCTET_LENGTH',
427     'OF',
428     'OFFSET',
429     'ON',
430     'ONLY',
431     'OPEN',
432     'OR',
433     'ORDER',
434     'OUTER',
435     'OVER',
436     'PARAMETER',
437     'PLAN',
438     'POSITION',
439     'POST_EVENT',
440     'PRECISION',
441     'PRIMARY',
442     'PROCEDURE',
443     'RDB$DB_KEY',
444     'RDB$RECORD_VERSION',
445     'REAL',
446     'RECORD_VERSION',
447     'RECREATE',
448     'RECURSIVE',
449     'REFERENCES',
450     'REGR_AVGX',
451     'REGR_AVGY',
452     'REGR_COUNT',
453     'REGR_INTERCEPT',
454     'REGR_R2',
455     'REGR_SLOPE',
456     'REGR_SXX',
457     'REGR_SXY',
458     'REGR_SYY',
459     'RELEASE',
460     'RETURN',
461     'RETURNING_VALUES',
462     'RETURNS',
463     'REVOKE',
464     'RIGHT',
465     'ROLLBACK',
466     'ROW',
467 tony 263 'ROWS',
468 tony 47 'ROW_COUNT',
469     'SAVEPOINT',
470     'SCROLL',
471     'SECOND',
472     'SELECT',
473     'SENSITIVE',
474     'SET',
475     'SIMILAR',
476     'SMALLINT',
477     'SOME',
478     'SQLCODE',
479     'SQLSTATE',
480     'START',
481     'STDDEV_POP',
482     'STDDEV_SAMP',
483     'SUM',
484     'TABLE',
485     'THEN',
486     'TIME',
487     'TIMESTAMP',
488     'TO',
489     'TRAILING',
490     'TRIGGER',
491     'TRIM',
492     'TRUE',
493     'UNION',
494     'UNIQUE',
495     'UNKNOWN',
496     'UPDATE',
497     'UPDATING',
498     'UPPER',
499     'USER',
500     'USING',
501     'VALUE',
502     'VALUES',
503     'VAR_POP',
504     'VAR_SAMP',
505     'VARCHAR',
506     'VARIABLE',
507     'VARYING',
508     'VIEW',
509     'WHEN',
510     'WHERE',
511     'WHILE',
512     'WITH',
513     'YEAR'
514     );
515 tony 45
516 tony 263 type
517     {The TSQLTokeniser class provides a common means to parse an SQL statement, or
518     even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
519     with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
520     is instantiated with a stream from which the SQL statements are read.
521    
522     Successive calls to GetNextToken then return each SQL token. The TokenText contains
523     either the single character, the identifier or reserved word, the string or comment.}
524    
525     { TSQLTokeniser }
526    
527     TSQLTokeniser = class
528     private
529     const
530     TokenQueueMaxSize = 64;
531     type
532     TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
533     stInIdentifier, stInNumeric);
534    
535     TTokenQueueItem = record
536     token: TSQLTokens;
537     text: AnsiString;
538     end;
539     TTokenQueueState = (tsHold, tsRelease);
540    
541     private
542     FLastChar: AnsiChar;
543     FState: TLexState;
544     FSkipNext: boolean;
545     function GetNext: TSQLTokens;
546    
547     {The token Queue is available for use by descendents so that they can
548     hold back tokens in order to lookahead by token rather than just a single
549     character}
550    
551     private
552     FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
553     FQueueState: TTokenQueueState;
554     FQFirst: integer; {first and last pointers first=last => queue empty}
555     FQLast: integer;
556     FEOF: boolean;
557     procedure PopQueue(var token: TSQLTokens);
558     protected
559     FString: AnsiString;
560     FNextToken: TSQLTokens;
561     procedure Assign(source: TSQLTokeniser); virtual;
562     function GetChar: AnsiChar; virtual; abstract;
563     function TokenFound(var token: TSQLTokens): boolean; virtual;
564     function InternalGetNextToken: TSQLTokens; virtual;
565     procedure Reset; virtual;
566 tony 359 function ReadCharacters(NumOfChars: integer): AnsiString;
567 tony 263
568     {Token stack}
569     procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
570     procedure QueueToken(token: TSQLTokens); overload;
571     procedure ResetQueue; overload;
572     procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
573     procedure ResetQueue(token: TSQLTokens); overload;
574     procedure ReleaseQueue(var token: TSQLTokens); overload;
575     procedure ReleaseQueue; overload;
576     function GetQueuedText: AnsiString;
577     procedure SetTokenText(text: AnsiString);
578    
579     public
580     const
581     DefaultTerminator = ';';
582     public
583     constructor Create;
584     destructor Destroy; override;
585     function GetNextToken: TSQLTokens;
586     property EOF: boolean read FEOF;
587     property TokenText: AnsiString read FString;
588     end;
589    
590     { TSQLwithNamedParamsTokeniser }
591    
592     TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
593     private
594     type
595     TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
596     private
597     FState: TSQLState;
598     FNested: integer;
599     protected
600     procedure Assign(source: TSQLTokeniser); override;
601     procedure Reset; override;
602     function TokenFound(var token: TSQLTokens): boolean; override;
603     end;
604    
605 tony 270 { TSQLParamProcessor }
606    
607     TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
608     private
609     const
610     sIBXParam = 'IBXParam'; {do not localize}
611     private
612     FInString: AnsiString;
613     FIndex: integer;
614     function DoExecute(GenerateParamNames: boolean;
615     var slNames: TStrings): AnsiString;
616     protected
617     function GetChar: AnsiChar; override;
618     public
619     class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
620     var slNames: TStrings): AnsiString;
621     end;
622    
623 tony 363 TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
624 tony 270
625 tony 363 { TSQLXMLReader - used to save and read back blob and array data in a pseudo XML format}
626    
627     TSQLXMLReader = class(TSQLTokeniser)
628     private
629     type
630     TXMLStates = (stNoXML, stInTag,stInTagBody,
631     stAttribute,stAttributeValue,stQuotedAttributeValue,
632     stInEndTag, stInEndTagBody,
633     stXMLData);
634    
635     TXMLTag = (xtNone,xtBlob,xtArray,xtElt);
636    
637     TXMLTagDef = record
638     XMLTag: TXMLTag;
639     TagValue: string;
640     end;
641    
642     const
643     XMLTagDefs: array [xtBlob..xtElt] of TXMLTagDef = (
644     (XMLTag: xtBlob; TagValue: 'blob'),
645     (XMLTag: xtArray; TagValue: 'array'),
646     (XMLTag: xtElt; TagValue: 'elt')
647     );
648     MaxXMLTags = 20;
649     BlobLineLength = 40;
650    
651     public
652     const
653     ibx_blob = 'IBX_BLOB';
654     ibx_array = 'IBX_ARRAY';
655    
656     type
657     TBlobData = record
658     BlobIntf: IBlob;
659     SubType: cardinal;
660     end;
661    
662     TArrayData = record
663     ArrayIntf: IArray;
664     SQLType: cardinal;
665     relationName: string;
666     columnName: string;
667     dim: cardinal;
668     Size: cardinal;
669     Scale: integer;
670     CharSet: string;
671     bounds: TArrayBounds;
672     CurrentRow: integer;
673     Index: array of integer;
674     end;
675    
676     private
677     FOnProgressEvent: TOnProgressEvent;
678     FXMLState: TXMLStates;
679     FXMLTagStack: array [1..MaxXMLTags] of TXMLTag;
680     FXMLTagIndex: integer;
681     FAttributeName: string;
682     FBlobData: array of TBlobData;
683     FCurrentBlob: integer;
684     FBlobBuffer: PByte;
685     FArrayData: array of TArrayData;
686     FCurrentArray: integer;
687     FXMLString: string;
688     function FindTag(tag: string; var xmlTag: TXMLTag): boolean;
689     function GetArrayData(index: integer): TArrayData;
690     function GetArrayDataCount: integer;
691     function GetBlobData(index: integer): TBlobData;
692     function GetBlobDataCount: integer;
693     function GetTagName(xmltag: TXMLTag): string;
694     procedure ProcessAttributeValue(attrValue: string);
695     procedure ProcessBoundsList(boundsList: string);
696     procedure ProcessTagValue(tagValue: string);
697     procedure XMLTagInit(xmltag: TXMLTag);
698     function XMLTagEnd(var xmltag: TXMLTag): boolean;
699     procedure XMLTagEnter;
700     protected
701     function GetAttachment: IAttachment; virtual; abstract;
702     function GetTransaction: ITransaction; virtual; abstract;
703     function GetErrorPrefix: string; virtual; abstract;
704     function TokenFound(var token: TSQLTokens): boolean; override;
705     procedure Reset; override;
706     procedure ShowError(msg: string; params: array of const); overload; virtual;
707     procedure ShowError(msg: string); overload;
708     public
709     constructor Create;
710     procedure FreeDataObjects;
711     class function FormatBlob(Field: ISQLData): string; overload;
712     class function FormatBlob(contents: string; subtype:integer): string; overload;
713     class function FormatArray(ar: IArray): string;
714     property BlobData[index: integer]: TBlobData read GetBlobData;
715     property BlobDataCount: integer read GetBlobDataCount;
716     property ArrayData[index: integer]: TArrayData read GetArrayData;
717     property ArrayDataCount: integer read GetArrayDataCount;
718     property Attachment: IAttachment read GetAttachment;
719     property Transaction: ITransaction read GetTransaction;
720     property OnProgressEvent: TOnProgressEvent read FOnProgressEvent write FOnProgressEvent; {Progress Bar Support}
721     end;
722    
723     TJnlEntryType = (jeTransStart, jeTransCommit, jeTransCommitRet, jeTransRollback,
724     jeTransRollbackRet, jeTransEnd, jeQuery,jeUnknown);
725    
726     TJnlEntry = record
727     JnlEntryType: TJnlEntryType;
728     Timestamp: TDateTime;
729 tony 371 AttachmentID: cardinal;
730     SessionID: cardinal;
731     TransactionID: cardinal;
732     OldTransactionID: cardinal;
733 tony 363 TransactionName: AnsiString;
734     TPB: ITPB;
735     DefaultCompletion: TTransactionCompletion;
736     QueryText: AnsiString;
737     end;
738    
739     TOnNextJournalEntry = procedure(JnlEntry: TJnlEntry) of object;
740    
741     { TJournalProcessor - used to parse a client side journal}
742    
743     TJournalProcessor = class(TSQLTokeniser)
744     private
745 tony 371 type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,
746     lsGotAttachmentID, lsGotSessionID,
747 tony 363 lsGotTransactionID, lsGotOldTransactionID, lsGotText1Length,
748     lsGotText1, lsGotText2Length, lsGotText2);
749     private
750     FOnNextJournalEntry: TOnNextJournalEntry;
751     FInStream: TStream;
752     FFirebirdClientAPI: IFirebirdAPI;
753     procedure DoExecute;
754     function IdentifyJnlEntry(aTokenText: AnsiString): TJnlEntryType;
755     protected
756     function GetChar: AnsiChar; override;
757     property OnNextJournalEntry: TOnNextJournalEntry read FOnNextJournalEntry write FOnNextJournalEntry;
758     public
759     destructor Destroy; override;
760     class procedure Execute( aFileName: string; api: IFirebirdAPI; aOnNextJournalEntry: TOnNextJournalEntry);
761     class function JnlEntryText(je: TJnlEntryType): string;
762     end;
763    
764    
765 tony 45 function Max(n1, n2: Integer): Integer;
766     function Min(n1, n2: Integer): Integer;
767 tony 56 function RandomString(iLength: Integer): AnsiString;
768 tony 45 function RandomInteger(iLow, iHigh: Integer): Integer;
769 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
770     function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
771 tony 263 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
772     function IsReservedWord(w: AnsiString): boolean;
773 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
774     function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
775     function Space2Underscore(s: AnsiString): AnsiString;
776     function SQLSafeString(const s: AnsiString): AnsiString;
777 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
778 tony 117 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
779 tony 143 function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
780     PortNo: AnsiString = ''): AnsiString;
781     function ParseConnectString(ConnectString: AnsiString;
782     var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
783     var PortNo: AnsiString): boolean;
784     function GetProtocol(ConnectString: AnsiString): TProtocolAll;
785 tony 45
786 tony 315 {$IF declared(TFormatSettings)}
787     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
788     var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
789     {$IFEND}
790     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
791     var aTimezone: AnsiString; TimeOnly: boolean=false): boolean; overload;
792     procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
793     function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
794     function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
795     function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
796     function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
797     function StripLeadingZeros(Value: AnsiString): AnsiString;
798 tony 363 function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
799     procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
800 tony 315
801 tony 353
802 tony 45 implementation
803    
804 tony 353 uses FBMessages, Math
805 tony 263
806 tony 315 {$IFDEF FPC}
807 tony 263 ,RegExpr
808 tony 315 {$ELSE}
809     {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
810     , RegularExpressions
811     {$IFEND}
812 tony 263 {$ENDIF};
813 tony 117
814 tony 363 resourcestring
815     sXMLStackUnderflow = 'XML Stack Underflow';
816     sInvalidEndTag = 'XML End Tag Mismatch - %s';
817     sBadEndTagClosing = 'XML End Tag incorrectly closed';
818     sXMLStackOverFlow = 'XML Stack Overflow';
819     sXMLAttributeError = 'Unexpected attribute - "%s" = "%s"';
820     sInvalidBoundsList = 'Invalid array bounds list - "%s"';
821     sBinaryBlockMustbeEven = 'Binary block must have an even number of characters';
822     sArrayIndexError = 'Array Index Error (%d)';
823     sBlobIndexError = 'Blob Index Error (%d)';
824     sNoDatabase = 'Missing database for xml tag import';
825     sNoTransaction = 'Missing transaction for xml tag import';
826 tony 315
827 tony 363
828 tony 45 function Max(n1, n2: Integer): Integer;
829     begin
830     if (n1 > n2) then
831     result := n1
832     else
833     result := n2;
834     end;
835    
836     function Min(n1, n2: Integer): Integer;
837     begin
838     if (n1 < n2) then
839     result := n1
840     else
841     result := n2;
842     end;
843    
844 tony 56 function RandomString(iLength: Integer): AnsiString;
845 tony 45 begin
846     result := '';
847     while Length(result) < iLength do
848     result := result + IntToStr(RandomInteger(0, High(Integer)));
849     if Length(result) > iLength then
850     result := Copy(result, 1, iLength);
851     end;
852    
853     function RandomInteger(iLow, iHigh: Integer): Integer;
854     begin
855     result := Trunc(Random(iHigh - iLow)) + iLow;
856     end;
857    
858 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
859 tony 45 var
860     i: Integer;
861     begin
862     result := '';
863     for i := 1 to Length(st) do begin
864     if AnsiPos(st[i], CharsToStrip) = 0 then
865     result := result + st[i];
866     end;
867     end;
868    
869 tony 117 {Extracts SQL Identifier typically from a Dialect 3 encoding}
870 tony 45
871 tony 117 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
872 tony 45 begin
873     Value := Trim(Value);
874     if Dialect = 1 then
875     Value := AnsiUpperCase(Value)
876     else
877     begin
878     if (Value <> '') and (Value[1] = '"') then
879     begin
880     Delete(Value, 1, 1);
881     Delete(Value, Length(Value), 1);
882     Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
883     end
884     else
885     Value := AnsiUpperCase(Value);
886     end;
887     Result := Value;
888     end;
889    
890 tony 263 {Returns true if "w" is a Firebird SQL reserved word, and the
891     corresponding TSQLTokens value.}
892    
893     function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
894     var i: TSQLTokens;
895     begin
896     Result := true;
897     w := AnsiUpperCase(Trim(w));
898     for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
899     begin
900     if w = sqlReservedWords[i] then
901     begin
902     token := i;
903     Exit;
904     end;
905     if w < sqlReservedWords[i] then
906     break;
907     end;
908     Result := false;
909     end;
910    
911 tony 117 {Returns true if "w" is a Firebird SQL reserved word}
912 tony 45
913 tony 56 function IsReservedWord(w: AnsiString): boolean;
914 tony 263 var token: TSQLTokens;
915 tony 45 begin
916 tony 263 Result := FindReservedWord(w,token);
917 tony 45 end;
918    
919 tony 117 {Format an SQL Identifier according to SQL Dialect}
920    
921 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
922 tony 45 begin
923 tony 311 Value := TrimRight(Value);
924 tony 45 if Dialect = 1 then
925 tony 311 Value := AnsiUpperCase(Value)
926 tony 45 else
927 tony 117 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
928 tony 45 Result := Value;
929     end;
930    
931 tony 107 const
932     ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
933    
934 tony 117 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
935    
936 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
937     var i: integer;
938     begin
939     Result := false;
940     for i := 1 to Length(Value) do
941     if not (Value[i] in ValidSQLIdentifierChars) then Exit;
942     Result := true;
943     end;
944    
945 tony 315 function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
946     begin
947     scheme := AnsiUpperCase(scheme);
948     if scheme = 'INET' then
949     Result := inet
950     else
951     if scheme = 'INET4' then
952     Result := inet4
953     else
954     if scheme = 'INET6' then
955     Result := inet6
956     else
957     if scheme = 'XNET' then
958     Result := xnet
959     else
960     if scheme = 'WNET' then
961     Result := wnet
962     end;
963    
964 tony 117 {Extracts the Database Connect string from a Create Database Statement}
965    
966 tony 315 {$IF declared(TRegexpr)}
967 tony 117 function ExtractConnectString(const CreateSQL: AnsiString;
968     var ConnectString: AnsiString): boolean;
969     var RegexObj: TRegExpr;
970     begin
971     RegexObj := TRegExpr.Create;
972     try
973     {extact database file spec}
974     RegexObj.ModifierG := false; {turn off greedy matches}
975     RegexObj.ModifierI := true; {case insensitive match}
976     RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
977     Result := RegexObj.Exec(CreateSQL);
978     if Result then
979 tony 143 ConnectString := RegexObj.Match[2];
980 tony 117 finally
981     RegexObj.Free;
982     end;
983     end;
984 tony 143
985     function ParseConnectString(ConnectString: AnsiString; var ServerName,
986     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
987     ): boolean;
988 tony 231
989 tony 143 var RegexObj: TRegExpr;
990     begin
991     ServerName := '';
992     DatabaseName := ConnectString;
993     PortNo := '';
994     Protocol := unknownProtocol;
995     RegexObj := TRegExpr.Create;
996     try
997     {extact database file spec}
998     RegexObj.ModifierG := false; {turn off greedy matches}
999 tony 231 RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
1000 tony 143 Result := RegexObj.Exec(ConnectString);
1001     if Result then
1002     begin
1003     {URL type connect string}
1004 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
1005 tony 143 ServerName := RegexObj.Match[2];
1006     if RegexObj.MatchLen[3] > 0 then
1007     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
1008     DatabaseName := RegexObj.Match[4];
1009 tony 231 if ServerName = '' then
1010     DatabaseName := '/' + DatabaseName;
1011 tony 143 end
1012     else
1013     begin
1014 tony 231 {URL type connect string - local loop}
1015     RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
1016 tony 143 Result := RegexObj.Exec(ConnectString);
1017     if Result then
1018 tony 231 begin
1019 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
1020 tony 231 DatabaseName := RegexObj.Match[2];
1021     end
1022 tony 143 else
1023     begin
1024 tony 231 RegexObj.Expression := '^([a-zA-Z]:\\.*)';
1025 tony 143 Result := RegexObj.Exec(ConnectString);
1026     if Result then
1027 tony 231 Protocol := Local {Windows with leading drive ID}
1028 tony 143 else
1029     begin
1030 tony 231 RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
1031 tony 143 Result := RegexObj.Exec(ConnectString);
1032     if Result then
1033     begin
1034 tony 231 {Legacy TCP Format}
1035 tony 143 ServerName := RegexObj.Match[1];
1036     if RegexObj.MatchLen[2] > 0 then
1037     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
1038     DatabaseName := RegexObj.Match[3];
1039 tony 231 Protocol := TCP;
1040 tony 143 end
1041     else
1042     begin
1043 tony 231 RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
1044     Result := RegexObj.Exec(ConnectString);
1045     if Result then
1046     begin
1047     {Netbui}
1048     ServerName := RegexObj.Match[1];
1049     if RegexObj.MatchLen[2] > 0 then
1050     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
1051     DatabaseName := RegexObj.Match[3];
1052     Protocol := NamedPipe
1053     end
1054     else
1055     begin
1056     Result := true;
1057     Protocol := Local; {Assume local}
1058     end;
1059 tony 143 end;
1060     end;
1061     end;
1062     end;
1063     finally
1064     RegexObj.Free;
1065     end;
1066     end;
1067    
1068 tony 315 {$ELSE}
1069     {$IF declared(TRegex)}
1070     function ExtractConnectString(const CreateSQL: AnsiString;
1071     var ConnectString: AnsiString): boolean;
1072     var Regex: TRegEx;
1073     Match: TMatch;
1074 tony 143 begin
1075 tony 315 Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
1076     {extact database file spec}
1077     Match := Regex.Match(CreateSQL);
1078     Result := Match.Success and (Match.Groups.Count = 3);
1079     if Result then
1080     ConnectString := Match.Groups[2].Value;
1081 tony 143 end;
1082    
1083 tony 315 function ParseConnectString(ConnectString: AnsiString; var ServerName,
1084     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
1085     ): boolean;
1086    
1087     var Regex: TRegEx;
1088     Match: TMatch;
1089     begin
1090     ServerName := '';
1091     DatabaseName := ConnectString;
1092     PortNo := '';
1093     Protocol := unknownProtocol;
1094     {extact database file spec}
1095     Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
1096     Result := Match.Success and (Match.Groups.Count = 5);
1097     if Result then
1098     begin
1099     {URL type connect string}
1100     Protocol := SchemeToProtocol(Match.Groups[1].Value);
1101     ServerName := Match.Groups[2].Value;
1102     PortNo := Match.Groups[3].Value;
1103     DatabaseName := Match.Groups[4].Value;
1104     if ServerName = '' then
1105     DatabaseName := '/' + DatabaseName;
1106     end
1107     else
1108     begin
1109     {URL type connect string - local loop}
1110     Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
1111     Result := Match.Success and (Match.Groups.Count = 3);
1112     if Result then
1113     begin
1114     Protocol := SchemeToProtocol(Match.Groups[1].Value);
1115     DatabaseName := Match.Groups[2].Value;
1116     end
1117     else
1118     begin
1119     Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
1120     Result := Match.Success;
1121     if Result then
1122     Protocol := Local {Windows with leading drive ID}
1123     else
1124     begin
1125     Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
1126     Result := Match.Success and (Match.Groups.Count = 4);
1127     if Result then
1128     begin
1129     {Legacy TCP Format}
1130     ServerName := Match.Groups[1].Value;
1131     PortNo := Match.Groups[2].Value;
1132     DatabaseName := Match.Groups[3].Value;
1133     Protocol := TCP;
1134     end
1135     else
1136     begin
1137     Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
1138     Result := Match.Success and (Match.Groups.Count = 4);
1139     if Result then
1140     begin
1141     {Netbui}
1142     ServerName := Match.Groups[1].Value;
1143     PortNo := Match.Groups[2].Value;
1144     DatabaseName := Match.Groups[3].Value;
1145     Protocol := NamedPipe
1146     end
1147     else
1148     begin
1149     Result := true;
1150     Protocol := Local; {Assume local}
1151     end;
1152     end;
1153     end;
1154     end;
1155     end;
1156     end;
1157 tony 118 {$ELSE}
1158 tony 315 {cruder version of above for Delphi < XE. Older versions lack regular expression
1159 tony 121 handling.}
1160 tony 118 function ExtractConnectString(const CreateSQL: AnsiString;
1161     var ConnectString: AnsiString): boolean;
1162     var i: integer;
1163     begin
1164     Result := false;
1165     i := Pos('''',CreateSQL);
1166     if i > 0 then
1167     begin
1168     ConnectString := CreateSQL;
1169     delete(ConnectString,1,i);
1170     i := Pos('''',ConnectString);
1171     if i > 0 then
1172     begin
1173     delete(ConnectString,i,Length(ConnectString)-i+1);
1174     Result := true;
1175     end;
1176     end;
1177     end;
1178 tony 143
1179     function ParseConnectString(ConnectString: AnsiString;
1180     var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1181     var PortNo: AnsiString): boolean;
1182     begin
1183     Result := false;
1184     end;
1185    
1186 tony 315 {$IFEND}
1187     {$IFEND}
1188 tony 117
1189 tony 315 function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1190     var ServerName,
1191     DatabaseName: AnsiString;
1192     PortNo: AnsiString;
1193     begin
1194     if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1195     Result := unknownProtocol;
1196     end;
1197    
1198 tony 143 {Make a connect string in format appropriate protocol}
1199    
1200     function MakeConnectString(ServerName, DatabaseName: AnsiString;
1201     Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1202 tony 231
1203     function FormatURL: AnsiString;
1204     begin
1205     if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1206     Result := DatabaseName
1207     else
1208     Result := ServerName + '/' + DatabaseName;
1209     end;
1210    
1211 tony 143 begin
1212 tony 315 if ServerName = '' then ServerName := 'localhost';
1213 tony 143 if PortNo <> '' then
1214     case Protocol of
1215     NamedPipe:
1216     ServerName := ServerName + '@' + PortNo;
1217     Local,
1218     SPX,
1219     xnet: {do nothing};
1220     TCP:
1221     ServerName := ServerName + '/' + PortNo;
1222     else
1223     ServerName := ServerName + ':' + PortNo;
1224     end;
1225    
1226     case Protocol of
1227     TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
1228     SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
1229     NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1230     Local: Result := DatabaseName; {do not localize}
1231 tony 231 inet: Result := 'inet://' + FormatURL; {do not localize}
1232     inet4: Result := 'inet4://' + FormatURL; {do not localize}
1233     inet6: Result := 'inet6://' + FormatURL; {do not localize}
1234     wnet: Result := 'wnet://' + FormatURL; {do not localize}
1235     xnet: Result := 'xnet://' + FormatURL; {do not localize}
1236 tony 143 end;
1237     end;
1238    
1239 tony 117 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1240    
1241 tony 56 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1242 tony 45 begin
1243 tony 311 Value := TrimRight(Value);
1244 tony 45 if (Dialect = 3) and
1245 tony 115 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1246 tony 117 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
1247 tony 45 else
1248     Result := Value
1249     end;
1250    
1251 tony 117 {Replaces unknown characters in a string with underscores}
1252    
1253 tony 56 function Space2Underscore(s: AnsiString): AnsiString;
1254 tony 45 var
1255     k: integer;
1256     begin
1257     Result := s;
1258     for k := 1 to Length(s) do
1259 tony 117 if not (Result[k] in ValidSQLIdentifierChars) then
1260 tony 45 Result[k] := '_';
1261     end;
1262    
1263 tony 117 {Reformats an SQL string with single quotes duplicated.}
1264    
1265 tony 56 function SQLSafeString(const s: AnsiString): AnsiString;
1266 tony 47 begin
1267     Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1268     end;
1269 tony 45
1270 tony 270 { TSQLParamProcessor }
1271    
1272     function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1273     var slNames: TStrings): AnsiString;
1274     var token: TSQLTokens;
1275     iParamSuffix: Integer;
1276     begin
1277     Result := '';
1278     iParamSuffix := 0;
1279    
1280     while not EOF do
1281     begin
1282     token := GetNextToken;
1283     case token of
1284     sqltParam,
1285     sqltQuotedParam:
1286     begin
1287     Result := Result + '?';
1288     slNames.Add(TokenText);
1289     end;
1290    
1291     sqltPlaceHolder:
1292     if GenerateParamNames then
1293     begin
1294     Inc(iParamSuffix);
1295     slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1296     //add pointer to self to mark entry
1297     Result := Result + '?';
1298     end
1299     else
1300     IBError(ibxeSQLParseError, [SParamNameExpected]);
1301    
1302     sqltQuotedString:
1303     Result := Result + '''' + SQLSafeString(TokenText) + '''';
1304    
1305     sqltIdentifierInDoubleQuotes:
1306     Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1307    
1308     sqltComment:
1309     Result := Result + '/*' + TokenText + '*/';
1310    
1311     sqltCommentLine:
1312 tony 287 Result := Result + '--' + TokenText + LineEnding;
1313 tony 270
1314     sqltEOL:
1315     Result := Result + LineEnding;
1316    
1317     else
1318     Result := Result + TokenText;
1319     end;
1320     end;
1321     end;
1322    
1323     function TSQLParamProcessor.GetChar: AnsiChar;
1324     begin
1325     if FIndex <= Length(FInString) then
1326     begin
1327     Result := FInString[FIndex];
1328     Inc(FIndex);
1329     end
1330     else
1331     Result := #0;
1332     end;
1333    
1334     class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1335     GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1336     begin
1337     with self.Create do
1338     try
1339     FInString := sSQL;
1340     FIndex := 1;
1341     Result := DoExecute(GenerateParamNames,slNames);
1342     finally
1343     Free;
1344     end;
1345     end;
1346    
1347 tony 263 { TSQLwithNamedParamsTokeniser }
1348    
1349     procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1350     begin
1351     inherited Assign(source);
1352     if source is TSQLwithNamedParamsTokeniser then
1353     begin
1354     FState := TSQLwithNamedParamsTokeniser(source).FState;
1355     FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1356     end;
1357     end;
1358    
1359     procedure TSQLwithNamedParamsTokeniser.Reset;
1360     begin
1361     inherited Reset;
1362     FState := stInit;
1363     FNested := 0;
1364     end;
1365    
1366     function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1367     ): boolean;
1368     begin
1369     Result := inherited TokenFound(token);
1370     if not Result then Exit;
1371    
1372     case FState of
1373     stInit:
1374     begin
1375     case token of
1376     sqltColon:
1377     begin
1378     FState := stInParam;
1379     ResetQueue(token);
1380     end;
1381    
1382     sqltBegin:
1383     begin
1384     FState := stInBlock;
1385     FNested := 1;
1386     end;
1387    
1388     sqltOpenSquareBracket:
1389     FState := stInArrayDim;
1390    
1391     end;
1392     end;
1393    
1394     stInParam:
1395     begin
1396     case token of
1397     sqltIdentifier:
1398     token := sqltParam;
1399    
1400     sqltIdentifierInDoubleQuotes:
1401     token := sqltQuotedParam;
1402    
1403     else
1404     begin
1405     QueueToken(token);
1406     ReleaseQueue(token);
1407     end;
1408     end;
1409     FState := stInit;
1410     end;
1411    
1412     stInBlock:
1413     begin
1414     case token of
1415 tony 348 sqltBegin,
1416     sqltCase:
1417 tony 263 Inc(FNested);
1418    
1419     sqltEnd:
1420     begin
1421     Dec(FNested);
1422     if FNested = 0 then
1423     FState := stInit;
1424     end;
1425     end;
1426     end;
1427    
1428     stInArrayDim:
1429     begin
1430     if token = sqltCloseSquareBracket then
1431     FState := stInit;
1432     end;
1433     end;
1434    
1435     Result := (FState <> stInParam);
1436     end;
1437    
1438     { TSQLTokeniser }
1439    
1440     function TSQLTokeniser.GetNext: TSQLTokens;
1441     var C: AnsiChar;
1442     begin
1443     if EOF then
1444     Result := sqltEOF
1445     else
1446     begin
1447     C := GetChar;
1448     case C of
1449     #0:
1450     Result := sqltEOF;
1451     ' ',TAB:
1452     Result := sqltSpace;
1453     '0'..'9':
1454     Result := sqltNumberString;
1455     ';':
1456     Result := sqltSemiColon;
1457     '?':
1458     Result := sqltPlaceholder;
1459     '|':
1460     Result := sqltPipe;
1461     '"':
1462     Result := sqltDoubleQuotes;
1463     '''':
1464     Result := sqltSingleQuotes;
1465     '/':
1466     Result := sqltForwardSlash;
1467 tony 270 '\':
1468     Result := sqltBackslash;
1469 tony 263 '*':
1470     Result := sqltAsterisk;
1471     '(':
1472     Result := sqltOpenBracket;
1473     ')':
1474     Result := sqltCloseBracket;
1475     ':':
1476     Result := sqltColon;
1477     ',':
1478     Result := sqltComma;
1479     '.':
1480     Result := sqltPeriod;
1481     '=':
1482     Result := sqltEquals;
1483     '[':
1484     Result := sqltOpenSquareBracket;
1485     ']':
1486     Result := sqltCloseSquareBracket;
1487 tony 287 '-':
1488     Result := sqltMinus;
1489 tony 263 '<':
1490     Result := sqltLT;
1491     '>':
1492     Result := sqltGT;
1493     CR:
1494     Result := sqltCR;
1495     LF:
1496     Result := sqltEOL;
1497     else
1498     if C in ValidSQLIdentifierChars then
1499     Result := sqltIdentifier
1500     else
1501     Result := sqltOtherCharacter;
1502     end;
1503     FLastChar := C
1504     end;
1505     FNextToken := Result;
1506     end;
1507    
1508     procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1509     begin
1510     if FQFirst = FQLast then
1511     IBError(ibxeTokenQueueUnderflow,[]);
1512     token := FTokenQueue[FQFirst].token;
1513     FString := FTokenQueue[FQFirst].text;
1514     Inc(FQFirst);
1515     if FQFirst = FQLast then
1516     FQueueState := tsHold;
1517     end;
1518    
1519     procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1520     begin
1521     FString := source.FString;
1522     FNextToken := source.FNextToken;
1523     FTokenQueue := source.FTokenQueue;
1524     FQueueState := source.FQueueState;
1525     FQFirst := source.FQFirst;
1526     FQLast := source.FQLast;
1527     end;
1528    
1529     function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1530     begin
1531     Result := (FState = stDefault);
1532     if Result and (token = sqltIdentifier) then
1533     FindReservedWord(FString,token);
1534     end;
1535    
1536     procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1537     begin
1538     if FQLast > TokenQueueMaxSize then
1539     IBError(ibxeTokenQueueOverflow,[]);
1540     FTokenQueue[FQLast].token := token;
1541     FTokenQueue[FQLast].text := text;
1542     Inc(FQLast);
1543     end;
1544    
1545     procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1546     begin
1547     QueueToken(token,TokenText);
1548     end;
1549    
1550     procedure TSQLTokeniser.ResetQueue;
1551     begin
1552     FQFirst := 0;
1553     FQLast := 0;
1554     FQueueState := tsHold;
1555     end;
1556    
1557     procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1558     begin
1559     ResetQueue;
1560     QueueToken(token,text);
1561     end;
1562    
1563     procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1564     begin
1565     ResetQueue;
1566     QueueToken(token);
1567     end;
1568    
1569     procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1570     begin
1571     FQueueState := tsRelease;
1572     PopQueue(token);
1573     end;
1574    
1575     procedure TSQLTokeniser.ReleaseQueue;
1576     begin
1577     FQueueState := tsRelease;
1578     end;
1579    
1580     function TSQLTokeniser.GetQueuedText: AnsiString;
1581     var i: integer;
1582     begin
1583     Result := '';
1584     for i := FQFirst to FQLast do
1585     Result := Result + FTokenQueue[i].text;
1586     end;
1587    
1588     procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1589     begin
1590     FString := text;
1591     end;
1592    
1593     constructor TSQLTokeniser.Create;
1594     begin
1595     inherited Create;
1596     Reset;
1597     end;
1598    
1599     destructor TSQLTokeniser.Destroy;
1600     begin
1601     Reset;
1602     inherited Destroy;
1603     end;
1604    
1605     procedure TSQLTokeniser.Reset;
1606     begin
1607     FNextToken := sqltInit;
1608     FState := stDefault;
1609     FString := '';
1610     FEOF := false;
1611     ResetQueue;
1612     end;
1613    
1614 tony 359 function TSQLTokeniser.ReadCharacters(NumOfChars: integer): AnsiString;
1615     var i: integer;
1616     begin
1617     Result := FLastChar;
1618     for i := 2 to NumOfChars do
1619     begin
1620 tony 363 if GetNext = sqltEOF then Exit;
1621 tony 359 Result := Result + FLastChar;
1622     end;
1623 tony 363 GetNext;
1624 tony 359 end;
1625    
1626 tony 263 function TSQLTokeniser.GetNextToken: TSQLTokens;
1627     begin
1628     if FQueueState = tsRelease then
1629     repeat
1630     PopQueue(Result);
1631     FEOF := Result = sqltEOF;
1632     if TokenFound(Result) then
1633     Exit;
1634     until FQueueState <> tsRelease;
1635    
1636     Result := InternalGetNextToken;
1637     end;
1638    
1639     {a simple lookahead one algorithm to extra the next symbol}
1640    
1641     function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1642     var C: AnsiChar;
1643     begin
1644     Result := sqltEOF;
1645    
1646     if FNextToken = sqltInit then
1647     GetNext;
1648    
1649     repeat
1650 tony 353 if FSkipNext then
1651     begin
1652     FSkipNext := false;
1653     GetNext;
1654     end;
1655    
1656 tony 263 Result := FNextToken;
1657     C := FLastChar;
1658     GetNext;
1659    
1660 tony 353 if (Result = sqltCR) and (FNextToken = sqltEOL) then
1661 tony 263 begin
1662 tony 353 FSkipNext := true;
1663     Result := sqltEOL;
1664     C := LF;
1665 tony 263 end;
1666    
1667     case FState of
1668     stInComment:
1669     begin
1670     if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1671     begin
1672     FState := stDefault;
1673     Result := sqltComment;
1674     GetNext;
1675     end
1676     else
1677 tony 353 if Result = sqltEOL then
1678     FString := FString + LineEnding
1679     else
1680 tony 263 FString := FString + C;
1681     end;
1682    
1683     stInCommentLine:
1684     begin
1685     case Result of
1686     sqltEOL:
1687     begin
1688     FState := stDefault;
1689     Result := sqltCommentLine;
1690     end;
1691    
1692     else
1693     FString := FString + C;
1694     end;
1695     end;
1696    
1697     stSingleQuoted:
1698     begin
1699     if (Result = sqltSingleQuotes) then
1700     begin
1701     if (FNextToken = sqltSingleQuotes) then
1702     begin
1703     FSkipNext := true;
1704     FString := FString + C;
1705     end
1706     else
1707     begin
1708     Result := sqltQuotedString;
1709     FState := stDefault;
1710     end;
1711     end
1712     else
1713 tony 353 if Result = sqltEOL then
1714     FString := FString + LineEnding
1715     else
1716 tony 263 FString := FString + C;
1717     end;
1718    
1719     stDoubleQuoted:
1720     begin
1721     if (Result = sqltDoubleQuotes) then
1722     begin
1723     if (FNextToken = sqltDoubleQuotes) then
1724     begin
1725     FSkipNext := true;
1726     FString := FString + C;
1727     end
1728     else
1729     begin
1730     Result := sqltIdentifierInDoubleQuotes;
1731     FState := stDefault;
1732     end;
1733     end
1734     else
1735 tony 353 if Result = sqltEOL then
1736     FString := FString + LineEnding
1737     else
1738 tony 263 FString := FString + C;
1739     end;
1740    
1741     stInIdentifier:
1742     begin
1743     FString := FString + C;
1744     Result := sqltIdentifier;
1745     if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1746     FState := stDefault
1747     end;
1748    
1749     stInNumeric:
1750     begin
1751     FString := FString + C;
1752     if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1753     begin
1754     {malformed decimal}
1755     FState := stInIdentifier;
1756     Result := sqltIdentifier
1757     end
1758     else
1759     begin
1760     if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1761     FState := stDefault;
1762     Result := sqltNumberString;
1763     end;
1764     end;
1765    
1766     else {stDefault}
1767     begin
1768     FString := C;
1769     case Result of
1770    
1771     sqltPipe:
1772     if FNextToken = sqltPipe then
1773     begin
1774     Result := sqltConcatSymbol;
1775     FString := C + FLastChar;
1776     GetNext;
1777     end;
1778    
1779     sqltForwardSlash:
1780     begin
1781     if FNextToken = sqltAsterisk then
1782     begin
1783     FString := '';
1784     GetNext;
1785     FState := stInComment;
1786     end
1787 tony 287 end;
1788    
1789     sqltMinus:
1790     begin
1791     if FNextToken = sqltMinus then
1792 tony 263 begin
1793     FString := '';
1794     GetNext;
1795     FState := stInCommentLine;
1796     end;
1797     end;
1798    
1799     sqltSingleQuotes:
1800     begin
1801     FString := '';
1802     FState := stSingleQuoted;
1803     end;
1804    
1805     sqltDoubleQuotes:
1806     begin
1807     FString := '';
1808     FState := stDoubleQuoted;
1809     end;
1810    
1811     sqltIdentifier:
1812 tony 265 if FNextToken in [sqltIdentifier,sqltNumberString] then
1813 tony 263 FState := stInIdentifier;
1814    
1815     sqltNumberString:
1816     if FNextToken in [sqltNumberString,sqltPeriod] then
1817     FState := stInNumeric;
1818 tony 353
1819     sqltEOL:
1820     FString := LineEnding;
1821 tony 263 end;
1822     end;
1823     end;
1824    
1825     // writeln(FString);
1826     FEOF := Result = sqltEOF;
1827     until TokenFound(Result) or EOF;
1828     end;
1829    
1830 tony 315 function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1831     var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1832     {$IF declared(TFormatSettings)}
1833     begin
1834     {$IF declared(DefaultFormatSettings)}
1835     Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1836     {$ELSE}
1837     {$IF declared(FormatSettings)}
1838     Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1839     {$IFEND} {$IFEND}
1840     end;
1841    
1842     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1843     var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1844     {$IFEND}
1845     const
1846     whitespacechars = [' ',#$09,#$0A,#$0D];
1847     var i,j,l: integer;
1848     aTime: TDateTime;
1849     DMs: longint;
1850     begin
1851     Result := false;
1852     aTimezone := '';
1853     if aDateTimeStr <> '' then
1854     {$if declared(TFormatSettings)}
1855     with aFormatSettings do
1856     {$IFEND}
1857     begin
1858     aDateTime := 0;
1859     {Parse to get time zone info}
1860     i := 1;
1861     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1862     if not TimeOnly then
1863     begin
1864     {decode date}
1865     j := i;
1866     while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1867     if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1868     i := j; {otherwise start again i.e. assume time only}
1869     end;
1870    
1871     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1872     {decode time}
1873     j := i;
1874     while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1875     Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1876     if not Result then Exit;
1877     aDateTime := aDateTime + aTime;
1878     i := j;
1879    
1880     {is there a factional second part}
1881     if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1882     begin
1883     inc(i);
1884     inc(j);
1885     while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1886     if j > i then
1887     begin
1888     l := j-i;
1889     if l > 4 then l := 4;
1890     Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1891     if not Result then Exit;
1892    
1893     {adjust for number of significant digits}
1894     case l of
1895     3: DMs := DMs * 10;
1896     2: DMs := DMs * 100;
1897     1: DMs := DMs * 1000;
1898     end;
1899     aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1900     end;
1901     end;
1902     i := j;
1903    
1904     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1905     {decode time zone}
1906     if i < length(aDateTimeStr) then
1907     begin
1908     j := i;
1909     while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1910     aTimezone := system.copy(aDateTimeStr,i,j-i);
1911     end;
1912     Result := true;
1913     end
1914     end;
1915    
1916     {The following is similar to FPC DecodeTime except that the Firebird standard
1917     decimilliseconds is used instead of milliseconds for fractional seconds}
1918    
1919     procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1920     var DeciMillisecond: cardinal);
1921     var D : Double;
1922     l : cardinal;
1923     begin
1924     {conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1925     D := aTime * MSecsPerDay *10;
1926     if D < 0 then
1927     D := D - 0.5
1928     else
1929     D := D + 0.5;
1930     {rest hacked from FPC DecodeTIme}
1931     l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1932     Hour := l div 36000000;
1933     l := l mod 36000000;
1934     Minute := l div 600000;
1935     l := l mod 600000;
1936     Second := l div 10000;
1937     DeciMillisecond := l mod 10000;
1938     end;
1939    
1940     {The following is similar to FPC EncodeTime except that the Firebird standard
1941     decimilliseconds is used instead of milliseconds for fractional seconds}
1942    
1943     function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1944     const DMSecsPerDay = MSecsPerDay*10;
1945     var DMs: cardinal;
1946     D: Double;
1947     begin
1948     if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1949     begin
1950     DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1951     D := DMs/DMSecsPerDay;
1952     Result:=TDateTime(d)
1953     end
1954     else
1955     IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1956     end;
1957    
1958     {The following is similar to FPC FormatDateTime except that it additionally
1959     allows the timstamp to have a fractional seconds component with a resolution
1960     of four decimal places. This is appended to the result for FormatDateTime
1961     if the format string contains a "zzzz' string.}
1962    
1963     function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1964     var Hour, Minute, Second: word;
1965     DeciMillisecond: cardinal;
1966     begin
1967     if Pos('zzzz',fmt) > 0 then
1968     begin
1969     FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1970     fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1971     end;
1972     Result := FormatDateTime(fmt,aDateTime);
1973     end;
1974    
1975     function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1976     begin
1977     if EffectiveTimeOffsetMins > 0 then
1978     Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1979     else
1980     Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1981     end;
1982    
1983     function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1984     var i: integer;
1985     begin
1986     Result := false;
1987     TZOffset := Trim(TZOffset);
1988     for i := 1 to Length(TZOffset) do
1989     if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1990    
1991     Result := true;
1992     i := Pos(':',TZOffset);
1993     if i > 0 then
1994     dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1995     else
1996     dstOffset := StrToInt(TZOffset) * 60;
1997     end;
1998    
1999     function StripLeadingZeros(Value: AnsiString): AnsiString;
2000     var i: Integer;
2001     start: integer;
2002     begin
2003     Result := '';
2004     start := 1;
2005     if (Length(Value) > 0) and (Value[1] = '-') then
2006     begin
2007     Result := '-';
2008     start := 2;
2009     end;
2010     for i := start to Length(Value) do
2011     if Value[i] <> '0' then
2012     begin
2013     Result := Result + system.copy(Value, i, MaxInt);
2014     Exit;
2015     end;
2016     end;
2017    
2018 tony 363 function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
2019    
2020     function ToHex(aValue: byte): string;
2021     const
2022     HexChars: array [0..15] of char = '0123456789ABCDEF';
2023     begin
2024     Result := HexChars[aValue shr 4] +
2025     HexChars[(aValue and $0F)];
2026     end;
2027    
2028     var i, j: integer;
2029     begin
2030     i := 1;
2031     Result := '';
2032     if MaxLineLength = 0 then
2033     while i <= Length(octetString) do
2034     begin
2035     Result := Result + ToHex(byte(octetString[i]));
2036     Inc(i);
2037     end
2038     else
2039     while i <= Length(octetString) do
2040     begin
2041     for j := 1 to MaxLineLength do
2042     begin
2043     if i > Length(octetString) then
2044     Exit
2045     else
2046     Result := Result + ToHex(byte(octetString[i]));
2047     inc(i);
2048     end;
2049     Result := Result + LineEnding;
2050     end;
2051     end;
2052    
2053     procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
2054     begin
2055     TextOut.Add(StringToHex(octetString,MaxLineLength));
2056     end;
2057    
2058     { TSQLXMLReader }
2059    
2060     function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
2061     var i: TXMLTag;
2062     begin
2063     Result := false;
2064     for i := xtBlob to xtElt do
2065     if XMLTagDefs[i].TagValue = tag then
2066     begin
2067     xmlTag := XMLTagDefs[i].XMLTag;
2068     Result := true;
2069     break;
2070     end;
2071     end;
2072    
2073     function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
2074     begin
2075     if (index < 0) or (index > ArrayDataCount) then
2076     ShowError(sArrayIndexError,[index]);
2077     Result := FArrayData[index];
2078     end;
2079    
2080     function TSQLXMLReader.GetArrayDataCount: integer;
2081     begin
2082     Result := Length(FArrayData);
2083     end;
2084    
2085     function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
2086     begin
2087     if (index < 0) or (index > BlobDataCount) then
2088     ShowError(sBlobIndexError,[index]);
2089     Result := FBlobData[index];
2090     end;
2091    
2092     function TSQLXMLReader.GetBlobDataCount: integer;
2093     begin
2094     Result := Length(FBlobData);
2095     end;
2096    
2097     function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
2098     var i: TXMLTag;
2099     begin
2100     Result := 'unknown';
2101     for i := xtBlob to xtElt do
2102     if XMLTagDefs[i].XMLTag = xmltag then
2103     begin
2104     Result := XMLTagDefs[i].TagValue;
2105     Exit;
2106     end;
2107     end;
2108    
2109     procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
2110     begin
2111     case FXMLTagStack[FXMLTagIndex] of
2112     xtBlob:
2113     if FAttributeName = 'subtype' then
2114     FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
2115     else
2116     ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2117    
2118     xtArray:
2119     if FAttributeName = 'sqltype' then
2120     FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
2121     else
2122     if FAttributeName = 'relation_name' then
2123     FArrayData[FCurrentArray].relationName := attrValue
2124     else
2125     if FAttributeName = 'column_name' then
2126     FArrayData[FCurrentArray].columnName := attrValue
2127     else
2128     if FAttributeName = 'dim' then
2129     FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
2130     else
2131     if FAttributeName = 'length' then
2132     FArrayData[FCurrentArray].Size := StrToInt(attrValue)
2133     else
2134     if FAttributeName = 'scale' then
2135     FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
2136     else
2137     if FAttributeName = 'charset' then
2138     FArrayData[FCurrentArray].CharSet := attrValue
2139     else
2140     if FAttributeName = 'bounds' then
2141     ProcessBoundsList(attrValue)
2142     else
2143     ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2144    
2145     xtElt:
2146     if FAttributeName = 'ix' then
2147     with FArrayData[FCurrentArray] do
2148     Index[CurrentRow] := StrToInt(attrValue)
2149     else
2150     ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2151     end;
2152     end;
2153    
2154     procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
2155     var list: TStringList;
2156     i,j: integer;
2157     begin
2158     list := TStringList.Create;
2159     try
2160     list.Delimiter := ',';
2161     list.DelimitedText := boundsList;
2162     with FArrayData[FCurrentArray] do
2163     begin
2164     if dim <> list.Count then
2165     ShowError(sInvalidBoundsList,[boundsList]);
2166     SetLength(bounds,dim);
2167     for i := 0 to list.Count - 1 do
2168     begin
2169     j := Pos(':',list[i]);
2170     if j = 0 then
2171     raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
2172     bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
2173     bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
2174     end;
2175     end;
2176     finally
2177     list.Free;
2178     end;
2179     end;
2180    
2181     procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
2182    
2183     function nibble(hex: char): byte;
2184     begin
2185     case hex of
2186     '0': Result := 0;
2187     '1': Result := 1;
2188     '2': Result := 2;
2189     '3': Result := 3;
2190     '4': Result := 4;
2191     '5': Result := 5;
2192     '6': Result := 6;
2193     '7': Result := 7;
2194     '8': Result := 8;
2195     '9': Result := 9;
2196     'a','A': Result := 10;
2197     'b','B': Result := 11;
2198     'c','C': Result := 12;
2199     'd','D': Result := 13;
2200     'e','E': Result := 14;
2201     'f','F': Result := 15;
2202     end;
2203     end;
2204    
2205     procedure RemoveWhiteSpace(var hexData: string);
2206     var i: integer;
2207     begin
2208     {Remove White Space}
2209     i := 1;
2210     while i <= length(hexData) do
2211     begin
2212     case hexData[i] of
2213     ' ',#9,#10,#13:
2214     begin
2215     if i < Length(hexData) then
2216     Move(hexData[i+1],hexData[i],Length(hexData)-i);
2217     SetLength(hexData,Length(hexData)-1);
2218     end;
2219     else
2220     Inc(i);
2221     end;
2222     end;
2223     end;
2224    
2225     procedure WriteToBlob(hexData: string);
2226     var i,j : integer;
2227     blength: integer;
2228     P: PByte;
2229     begin
2230     RemoveWhiteSpace(hexData);
2231     if odd(length(hexData)) then
2232     ShowError(sBinaryBlockMustbeEven,[nil]);
2233     blength := Length(hexData) div 2;
2234     ReallocMem(FBlobBuffer,blength);
2235     j := 1;
2236     P := FBlobBuffer;
2237     for i := 1 to blength do
2238     begin
2239     P^ := (nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]);
2240     Inc(j,2);
2241     Inc(P);
2242     end;
2243     FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
2244     end;
2245    
2246     begin
2247     if tagValue = '' then Exit;
2248     case FXMLTagStack[FXMLTagIndex] of
2249     xtBlob:
2250     WriteToBlob(tagValue);
2251    
2252     xtElt:
2253     with FArrayData[FCurrentArray] do
2254     ArrayIntf.SetAsString(index,tagValue);
2255    
2256     end;
2257     end;
2258    
2259     procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
2260     begin
2261     if FXMLTagIndex > MaxXMLTags then
2262     ShowError(sXMLStackOverFlow,[nil]);
2263     Inc(FXMLTagIndex);
2264     FXMLTagStack[FXMLTagIndex] := xmltag;
2265     FXMLString := '';
2266    
2267     case xmltag of
2268     xtBlob:
2269     begin
2270     Inc(FCurrentBlob);
2271     SetLength(FBlobData,FCurrentBlob+1);
2272     FBlobData[FCurrentBlob].BlobIntf := nil;
2273     FBlobData[FCurrentBlob].SubType := 0;
2274     end;
2275    
2276     xtArray:
2277     begin
2278     Inc(FCurrentArray);
2279     SetLength(FArrayData,FCurrentArray+1);
2280     with FArrayData[FCurrentArray] do
2281     begin
2282     ArrayIntf := nil;
2283     SQLType := 0;
2284     dim := 0;
2285     Size := 0;
2286     Scale := 0;
2287     CharSet := 'NONE';
2288     SetLength(Index,0);
2289     CurrentRow := -1;
2290     end;
2291     end;
2292    
2293     xtElt:
2294     with FArrayData[FCurrentArray] do
2295     Inc(CurrentRow)
2296     end;
2297     end;
2298    
2299     function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
2300     begin
2301     if FXMLTagIndex = 0 then
2302     ShowError(sXMLStackUnderflow,[nil]);
2303    
2304     xmlTag := FXMLTagStack[FXMLTagIndex];
2305     case FXMLTagStack[FXMLTagIndex] of
2306     xtBlob:
2307     FBlobData[FCurrentBlob].BlobIntf.Close;
2308    
2309     xtArray:
2310     FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
2311    
2312     xtElt:
2313     Dec(FArrayData[FCurrentArray].CurrentRow);
2314     end;
2315     Dec(FXMLTagIndex);
2316     Result := FXMLTagIndex = 0;
2317     end;
2318    
2319     procedure TSQLXMLReader.XMLTagEnter;
2320     var aCharSetID: integer;
2321     begin
2322     if (Attachment = nil) or not Attachment.IsConnected then
2323     ShowError(sNoDatabase);
2324     if Transaction = nil then
2325     ShowError(sNoTransaction);
2326     case FXMLTagStack[FXMLTagIndex] of
2327     xtBlob:
2328     begin
2329     if not Transaction.InTransaction then
2330     Transaction.Start;
2331     FBlobData[FCurrentBlob].BlobIntf := Attachment.CreateBlob(
2332     Transaction,FBlobData[FCurrentBlob].SubType);
2333     end;
2334    
2335     xtArray:
2336     with FArrayData[FCurrentArray] do
2337     begin
2338     if not Transaction.InTransaction then
2339     Transaction.Start;
2340     Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
2341     SetLength(Index,dim);
2342     ArrayIntf := Attachment.CreateArray(
2343     Transaction,
2344     Attachment.CreateArrayMetaData(SQLType,
2345     relationName,columnName,Scale,Size,
2346     aCharSetID,dim,bounds)
2347     );
2348     end;
2349     end;
2350     end;
2351    
2352     {This is where the XML tags are identified and the token stream modified in
2353     consequence}
2354    
2355     function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
2356    
2357     procedure NotAnXMLTag;
2358     begin
2359     begin
2360     if FXMLTagIndex = 0 then
2361     {nothing to do with XML so go back to processing SQL}
2362     begin
2363     QueueToken(token);
2364     ReleaseQueue(token);
2365     FXMLState := stNoXML
2366     end
2367     else
2368     begin
2369     {Not an XML tag, so just push back to XML Data}
2370     FXMLState := stXMLData;
2371     FXMLString := FXMLString + GetQueuedText;
2372     ResetQueue;
2373     end;
2374     end;
2375     end;
2376    
2377     var XMLTag: TXMLTag;
2378     begin
2379     Result := inherited TokenFound(token);
2380     if not Result then Exit;
2381    
2382     case FXMLState of
2383     stNoXML:
2384     if token = sqltLT then
2385     begin
2386     ResetQueue;
2387     QueueToken(token); {save in case this is not XML}
2388     FXMLState := stInTag;
2389     end;
2390    
2391     stInTag:
2392     {Opening '<' found, now looking for tag name or end tag marker}
2393     case token of
2394     sqltIdentifier:
2395     begin
2396     if FindTag(TokenText,XMLTag) then
2397     begin
2398     XMLTagInit(XMLTag);
2399     QueueToken(token);
2400     FXMLState := stInTagBody;
2401     end
2402     else
2403     NotAnXMLTag;
2404     end;
2405    
2406     sqltForwardSlash:
2407     FXMLState := stInEndTag;
2408    
2409     else
2410     NotAnXMLTag;
2411     end {case token};
2412    
2413     stInTagBody:
2414     {Tag name found. Now looking for attribute or closing '>'}
2415     case token of
2416     sqltIdentifier:
2417     begin
2418     FAttributeName := TokenText;
2419     QueueToken(token);
2420     FXMLState := stAttribute;
2421     end;
2422    
2423     sqltGT:
2424     begin
2425     ResetQueue;
2426     XMLTagEnter;
2427     FXMLState := stXMLData;
2428     end;
2429    
2430     sqltSpace,
2431     sqltEOL:
2432     QueueToken(token);
2433    
2434     else
2435     NotAnXMLTag;
2436     end {case token};
2437    
2438     stAttribute:
2439     {Attribute name found. Must be followed by an '=', a '>' or another tag name}
2440     case token of
2441     sqltEquals:
2442     begin
2443     QueueToken(token);
2444     FXMLState := stAttributeValue;
2445     end;
2446    
2447     sqltSpace,
2448     sqltEOL:
2449     QueueToken(token);
2450    
2451     sqltIdentifier:
2452     begin
2453     ProcessAttributeValue('');
2454     FAttributeName := TokenText;
2455     QueueToken(token);
2456     FXMLState := stAttribute;
2457     end;
2458    
2459     sqltGT:
2460     begin
2461     ProcessAttributeValue('');
2462     ResetQueue;
2463     XMLTagEnter;
2464     FXMLState := stXMLData;
2465     end;
2466    
2467     else
2468     NotAnXMLTag;
2469     end; {case token}
2470    
2471     stAttributeValue:
2472     {Looking for attribute value as a single identifier or a double quoted value}
2473     case token of
2474     sqltIdentifier,sqltIdentifierInDoubleQuotes:
2475     begin
2476     ProcessAttributeValue(TokenText);
2477     QueueToken(token);
2478     FXMLState := stInTagBody;
2479     end;
2480    
2481     sqltSpace,
2482     sqltEOL:
2483     QueueToken(token);
2484    
2485     else
2486     NotAnXMLTag;
2487     end; {case token}
2488    
2489     stXMLData:
2490     if token = sqltLT then
2491     begin
2492     QueueToken(token); {save in case this is not XML}
2493     FXMLState := stInTag;
2494     end
2495     else
2496     FXMLString := FXMLString + TokenText;
2497    
2498     stInEndTag:
2499     {Opening '</' found, now looking for tag name}
2500     case token of
2501     sqltIdentifier:
2502     begin
2503     if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
2504     begin
2505     QueueToken(token);
2506     FXMLState := stInEndTagBody;
2507     end
2508     else
2509     ShowError(sInvalidEndTag,[TokenText]);
2510     end;
2511     else
2512     NotAnXMLTag;
2513     end {case token};
2514    
2515     stInEndTagBody:
2516     {End tag name found, now looping for closing '>'}
2517     case Token of
2518     sqltGT:
2519     begin
2520     ProcessTagValue(FXMLString);
2521     if XMLTagEnd(XMLTag) then
2522     begin
2523     ResetQueue;
2524     QueueToken(sqltColon,':');
2525     case XMLTag of
2526     xtBlob:
2527     QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
2528    
2529     xtArray:
2530     QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
2531     end;
2532     ReleaseQueue(token);
2533     FXMLState := stNoXML;
2534     end
2535     else
2536     FXMLState := stXMLData;
2537     end;
2538    
2539     sqltSpace,
2540     sqltEOL:
2541     QueueToken(token);
2542    
2543     else
2544     ShowError(sBadEndTagClosing);
2545     end; {case token}
2546    
2547     end {Case FState};
2548    
2549     {Only allow token to be returned if not processing an XML tag}
2550    
2551     Result := FXMLState = stNoXML;
2552     end;
2553    
2554     procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
2555     begin
2556     raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
2557     end;
2558    
2559     procedure TSQLXMLReader.ShowError(msg: string);
2560     begin
2561     ShowError(msg,[nil]);
2562     end;
2563    
2564     constructor TSQLXMLReader.Create;
2565     begin
2566     inherited;
2567     FXMLState := stNoXML;
2568     end;
2569    
2570     procedure TSQLXMLReader.FreeDataObjects;
2571     begin
2572     FXMLTagIndex := 0;
2573     SetLength(FBlobData,0);
2574     FCurrentBlob := -1;
2575     SetLength(FArrayData,0);
2576     FCurrentArray := -1;
2577     end;
2578    
2579     class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
2580     begin
2581     Result := FormatBlob(Field.AsString,Field.getSubtype);
2582     end;
2583    
2584     class function TSQLXMLReader.FormatBlob(contents: string; subtype: integer
2585     ): string;
2586     var TextOut: TStrings;
2587     begin
2588     TextOut := TStringList.Create;
2589     try
2590     TextOut.Add(Format('<blob subtype="%d">',[subtype]));
2591     StringToHex(contents,TextOut,BlobLineLength);
2592     TextOut.Add('</blob>');
2593     Result := TextOut.Text;
2594     finally
2595     TextOut.Free;
2596     end;
2597     end;
2598    
2599    
2600     class function TSQLXMLReader.FormatArray(ar: IArray
2601     ): string;
2602     var index: array of integer;
2603     TextOut: TStrings;
2604    
2605     procedure AddElements(dim: integer; indent:string = ' ');
2606     var i: integer;
2607     recurse: boolean;
2608     begin
2609     SetLength(index,dim+1);
2610     recurse := dim < ar.GetDimensions - 1;
2611     with ar.GetBounds[dim] do
2612     for i := LowerBound to UpperBound do
2613     begin
2614     index[dim] := i;
2615     if recurse then
2616     begin
2617     TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
2618     AddElements(dim+1,indent + ' ');
2619     TextOut.Add('</elt>');
2620     end
2621     else
2622     if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
2623     (ar.GetCharSetID = 1) then
2624     TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
2625     else
2626     TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
2627     end;
2628     end;
2629    
2630     var
2631     s: string;
2632     bounds: TArrayBounds;
2633     i: integer;
2634     boundsList: string;
2635     begin
2636     TextOut := TStringList.Create;
2637     try
2638     if ar.GetCharSetWidth = 0 then
2639     s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2640     [ar.GetDimensions,ar.GetSQLType,ar.GetSize,
2641     ar.GetTableName,ar.GetColumnName])
2642     else
2643     s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2644     [ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
2645     ar.GetTableName,ar.GetColumnName]);
2646     case ar.GetSQLType of
2647     SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
2648     s := s + Format(' scale = "%d"',[ ar.GetScale]);
2649     SQL_TEXT,
2650     SQL_VARYING:
2651     s := s + Format(' charset = "%s"',[ar.GetAttachment.GetCharsetName(ar.GetCharSetID)]);
2652     end;
2653     bounds := ar.GetBounds;
2654     boundsList := '';
2655     for i := 0 to length(bounds) - 1 do
2656     begin
2657     if i <> 0 then boundsList := boundsList + ',';
2658     boundsList := boundsList + Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
2659     end;
2660     s := s + Format(' bounds="%s"',[boundsList]);
2661     s := s + '>';
2662     TextOut.Add(s);
2663    
2664     SetLength(index,0);
2665     AddElements(0);
2666     TextOut.Add('</array>');
2667     Result := TextOut.Text;
2668     finally
2669     TextOut.Free;
2670     end;
2671     end;
2672    
2673     procedure TSQLXMLReader.Reset;
2674     begin
2675     inherited Reset;
2676     FreeDataObjects;
2677     FXMLString := '';
2678     FreeMem(FBlobBuffer);
2679     end;
2680    
2681     { TJournalProcessor }
2682    
2683     procedure TJournalProcessor.DoExecute;
2684     var token: TSQLTokens;
2685     LineState: TLineState;
2686     JnlEntry: TJnlEntry;
2687     Len: integer;
2688     tz: AnsiString;
2689    
2690     procedure ClearJnlEntry;
2691     begin
2692     with JnlEntry do
2693     begin
2694     TransactionName := '';
2695     TPB := nil;
2696     QueryText :='';
2697     JnlEntryType := jeUnknown;
2698     SessionID := 0;
2699     TransactionID := 0;
2700     DefaultCompletion := taCommit;
2701     end;
2702     end;
2703    
2704     function CreateTPB(TPBText: AnsiString): ITPB;
2705     var index: integer;
2706     begin
2707     Result := nil;
2708     if Length(TPBText) = 0 then
2709     Exit;
2710     Result := FFirebirdClientAPI.AllocateTPB;
2711     try
2712     index := Pos('[',TPBText);
2713     if index > 0 then
2714     system.Delete(TPBText,1,index);
2715     repeat
2716     index := Pos(',',TPBText);
2717     if index = 0 then
2718     begin
2719     index := Pos(']',TPBText);
2720     if index <> 0 then
2721     system.Delete(TPBText,index,1);
2722     Result.AddByTypeName(TPBText);
2723     break;
2724     end;
2725     Result.AddByTypeName(system.copy(TPBText,1,index-1));
2726     system.Delete(TPBText,1,index);
2727     until false;
2728     except
2729     Result := nil;
2730     raise;
2731     end;
2732     end;
2733    
2734     begin
2735     LineState := lsInit;
2736     JnlEntry.JnlEntryType := jeUnknown;
2737     while not EOF do
2738     begin
2739     if LineState = lsInit then
2740     ClearJnlEntry;
2741     token := GetNextToken;
2742     with JnlEntry do
2743     case token of
2744     sqltAsterisk:
2745     if LineState = lsInit then
2746     LineState := lsJnlFound;
2747    
2748     sqltIdentifier:
2749     if LineState = lsJnlFound then
2750     begin
2751     JnlEntryType := IdentifyJnlEntry(TokenText);
2752     LineState := lsGotJnlType;
2753     end
2754     else
2755     LineState := lsInit;
2756    
2757     sqltQuotedString:
2758     if (LineState = lsGotJnlType)
2759     and ParseDateTimeTZString(TokenText,TimeStamp,tz) then
2760     LineState := lsGotTimestamp
2761     else
2762     LineState := lsInit;
2763    
2764     sqltColon:
2765     case LineState of
2766     lsGotText1Length:
2767     begin
2768     if Len > 0 then
2769     begin
2770     if JnlEntryType = jeTransStart then
2771     TransactionName := ReadCharacters(Len)
2772     else
2773     QueryText := ReadCharacters(Len)
2774     end;
2775     if JnlEntryType = jeTransStart then
2776     LineState := lsGotText1
2777     else
2778     begin
2779     if assigned(FOnNextJournalEntry) then
2780     OnNextJournalEntry(JnlEntry);
2781     LineState := lsInit;
2782     end
2783     end;
2784    
2785     lsGotText2Length:
2786     begin
2787     if Len > 0 then
2788     TPB := CreateTPB(ReadCharacters(Len));
2789     LineState := lsGotText2;
2790     end;
2791    
2792     else
2793     if LineState <> lsGotJnlType then
2794     LineState := lsInit;
2795     end;
2796    
2797     sqltComma:
2798 tony 371 if not (LineState in [lsGotTimestamp,lsGotAttachmentID,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2799 tony 363 LineState := lsInit;
2800    
2801     sqltNumberString:
2802     case LineState of
2803     lsGotTimestamp:
2804     begin
2805 tony 371 AttachmentID := StrToInt(TokenText);
2806     LineState := lsGotAttachmentID;
2807     end;
2808    
2809     lsGotAttachmentID:
2810     begin
2811 tony 363 SessionID := StrToInt(TokenText);
2812     LineState := lsGotSessionID;
2813     end;
2814    
2815     lsGotSessionID:
2816     begin
2817     TransactionID := StrToInt(TokenText);
2818     if JnlEntryType in [jeTransCommit, jeTransRollback] then
2819     begin
2820     if assigned(FOnNextJournalEntry) then
2821     OnNextJournalEntry(JnlEntry);
2822     LineState := lsInit;
2823     end
2824     else
2825     LineState := lsGotTransactionID;
2826     end;
2827    
2828     lsGotTransactionID:
2829     begin
2830     case JnlEntryType of
2831     jeTransStart:
2832     begin
2833     len := StrToInt(TokenText);
2834     LineState := lsGotText1Length;
2835     end;
2836    
2837     jeQuery:
2838     begin
2839     len := StrToInt(TokenText);
2840     LineState := lsGotText1Length;
2841     end;
2842    
2843     jeTransCommitRet,
2844     jeTransRollbackRet:
2845     begin
2846     OldTransactionID := StrToInt(TokenText);
2847     if assigned(FOnNextJournalEntry) then
2848     OnNextJournalEntry(JnlEntry);
2849     LineState := lsInit;
2850     end;
2851    
2852     else
2853     LineState := lsInit;
2854     end; {case JnlEntryType}
2855    
2856     end;
2857    
2858     lsGotText1:
2859     begin
2860     len := StrToInt(TokenText);
2861     LineState := lsGotText2Length;
2862     end;
2863    
2864     lsGotText2:
2865     begin
2866     if JnlEntryType = jeTransStart then
2867     begin
2868     DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2869     if assigned(FOnNextJournalEntry) then
2870     OnNextJournalEntry(JnlEntry);
2871     end;
2872     LineState := lsInit;
2873     end;
2874     end; {case LineState}
2875     end; {case token}
2876     end; {while}
2877     ClearJnlEntry;
2878     end;
2879    
2880     function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2881     ): TJnlEntryType;
2882     begin
2883     Result := jeUnknown;
2884     if Length(aTokenText) > 0 then
2885     case aTokenText[1] of
2886     'S':
2887     Result := jeTransStart;
2888     'C':
2889     Result := jeTransCommit;
2890     'c':
2891     Result := jeTransCommitRet;
2892     'R':
2893     Result := jeTransRollback;
2894     'r':
2895     Result := jeTransRollbackRet;
2896     'E':
2897     Result := jeTransEnd;
2898     'Q':
2899     Result := jeQuery;
2900     end;
2901     end;
2902    
2903     class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2904     begin
2905     case je of
2906     jeTransStart:
2907     Result := 'Transaction Start';
2908     jeTransCommit:
2909     Result := 'Commit';
2910     jeTransCommitRet:
2911     Result := 'Commit Retaining';
2912     jeTransRollback:
2913     Result := 'Rollback';
2914     jeTransRollbackRet:
2915     Result := 'Rollback Retaining';
2916     jeTransEnd:
2917     Result := 'Transaction End';
2918     jeQuery:
2919     Result := 'Query';
2920     jeUnknown:
2921     Result := 'Unknown';
2922     end;
2923     end;
2924    
2925     function TJournalProcessor.GetChar: AnsiChar;
2926     begin
2927     if FInStream.Read(Result,1) = 0 then
2928     Result := #0;
2929     end;
2930    
2931     destructor TJournalProcessor.Destroy;
2932     begin
2933     FInStream.Free;
2934     inherited Destroy;
2935     end;
2936    
2937     class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
2938     aOnNextJournalEntry: TOnNextJournalEntry);
2939     begin
2940     with TJournalProcessor.Create do
2941     try
2942     FInStream := TFileStream.Create(aFileName,fmOpenRead);
2943     FFirebirdClientAPI := api;
2944     OnNextJournalEntry := aOnNextJournalEntry;
2945     DoExecute;
2946     finally
2947     Free
2948     end;
2949     end;
2950    
2951    
2952 tony 45 end.