ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
(Generate patch)

Comparing:
ibx/trunk/fbintf/IBUtils.pas (file contents), Revision 115 by tony, Fri Jan 19 09:23:39 2018 UTC vs.
ibx/branches/journaling/fbintf/IBUtils.pas (file contents), Revision 363 by tony, Tue Dec 7 13:30:05 2021 UTC

# Line 33 | Line 33
33  
34   unit IBUtils;
35   {$IFDEF MSWINDOWS}
36 < {$DEFINE WINDOWS}
36 > {$DEFINE WINDOWS}
37   {$ENDIF}
38  
39   {$IFDEF FPC}
# Line 41 | Line 41 | unit IBUtils;
41   {$codepage UTF8}
42   {$ENDIF}
43  
44 + { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45 + { $define HASDELPHIREQEX}
46 + { $IFEND}
47 +
48   interface
49  
50 < uses Classes, SysUtils;
50 > uses Classes, SysUtils, IB;
51 >
52 > {$IF not defined(LineEnding)}
53 > const
54 >  {$IFDEF WINDOWS}
55 >  LineEnding = #$0D#$0A;
56 >  {$ELSE}
57 >  LineEnding = #$0A;
58 >  {$ENDIF}
59 > {$IFEND}
60 >
61 > 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 >  sqltBackslash,
273 >  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 >  sqltMinus,
295 >  sqltConcatSymbol,
296 >  sqltLT,
297 >  sqltGT,
298 >  sqltCR,
299 >  sqltEOL,
300 >  sqltEOF,
301 >  sqltInit
302 >  );
303 >
304 >  TSQLReservedWords = sqltAdd..sqltYear;
305  
306   const
307    CRLF = #13 + #10;
# Line 52 | Line 310 | const
310    TAB  = #9;
311    NULL_TERMINATOR = #0;
312  
313 <  sqlReservedWords: array [0..197] of string = (
313 >  {SQL Reserved words in alphabetical order}
314 >
315 >  sqlReservedWords: array [TSQLReservedWords] of string = (
316    'ADD',
317    'ADMIN',
318    'ALL',
# Line 144 | Line 404 | const
404    'INTO',
405    'IS',
406    'JOIN',
407 +  'KEY',
408    'LEADING',
409    'LEFT',
410    'LIKE',
# Line 203 | Line 464 | const
464    'RIGHT',
465    'ROLLBACK',
466    'ROW',
206 –  'ROW_COUNT',
467    'ROWS',
468 +  'ROW_COUNT',
469    'SAVEPOINT',
470    'SCROLL',
471    'SECOND',
# Line 216 | Line 477 | const
477    'SOME',
478    'SQLCODE',
479    'SQLSTATE',
219 –  'SQLSTATE',
480    'START',
481    'STDDEV_POP',
482    'STDDEV_SAMP',
# Line 253 | Line 513 | const
513    'YEAR'
514    );
515  
516 + 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 +    function ReadCharacters(NumOfChars: integer): AnsiString;
567 +
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 +    { 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 +  TOnProgressEvent = procedure (Sender: TObject; Reset: boolean; value: integer) of object;
624 +
625 +  { 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 +   SessionID: integer;
730 +   TransactionID: integer;
731 +   OldTransactionID: integer;
732 +   TransactionName: AnsiString;
733 +   TPB: ITPB;
734 +   DefaultCompletion: TTransactionCompletion;
735 +   QueryText: AnsiString;
736 + end;
737 +
738 + TOnNextJournalEntry = procedure(JnlEntry: TJnlEntry) of object;
739 +
740 + { TJournalProcessor - used to parse a client side journal}
741 +
742 +   TJournalProcessor = class(TSQLTokeniser)
743 +    private
744 +      type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,  lsGotSessionID,
745 +                          lsGotTransactionID,  lsGotOldTransactionID, lsGotText1Length,
746 +                          lsGotText1, lsGotText2Length, lsGotText2);
747 +    private
748 +      FOnNextJournalEntry: TOnNextJournalEntry;
749 +      FInStream: TStream;
750 +      FFirebirdClientAPI: IFirebirdAPI;
751 +      procedure DoExecute;
752 +      function IdentifyJnlEntry(aTokenText: AnsiString): TJnlEntryType;
753 +    protected
754 +      function GetChar: AnsiChar; override;
755 +      property OnNextJournalEntry: TOnNextJournalEntry read FOnNextJournalEntry write FOnNextJournalEntry;
756 +    public
757 +      destructor Destroy; override;
758 +      class procedure Execute( aFileName: string; api: IFirebirdAPI; aOnNextJournalEntry: TOnNextJournalEntry);
759 +      class function JnlEntryText(je: TJnlEntryType): string;
760 +    end;
761 +
762 +
763   function Max(n1, n2: Integer): Integer;
764   function Min(n1, n2: Integer): Integer;
765   function RandomString(iLength: Integer): AnsiString;
766   function RandomInteger(iLow, iHigh: Integer): Integer;
767   function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
261 – function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
262 – function FormatIdentifierValue(Dialect: Integer; Value: AnsiString): AnsiString;
263 – function FormatIdentifierValueNC(Dialect: Integer; Value: AnsiString): AnsiString;
768   function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
769 + function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
770 + function IsReservedWord(w: AnsiString): boolean;
771   function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
772   function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
773   function Space2Underscore(s: AnsiString): AnsiString;
774   function SQLSafeString(const s: AnsiString): AnsiString;
775   function IsSQLIdentifier(Value: AnsiString): boolean;
776 + function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
777 + function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
778 +              PortNo: AnsiString = ''): AnsiString;
779 + function ParseConnectString(ConnectString: AnsiString;
780 +              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
781 +              var PortNo: AnsiString): boolean;
782 + function GetProtocol(ConnectString: AnsiString): TProtocolAll;
783 +
784 + {$IF declared(TFormatSettings)}
785 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
786 +              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
787 + {$IFEND}
788 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
789 +              var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
790 + procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
791 + function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
792 + function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
793 + function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
794 + function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
795 + function StripLeadingZeros(Value: AnsiString): AnsiString;
796 + function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
797 + function NumericToDouble(aValue: Int64; aScale: integer): double;
798 + function StringToHex(octetString: string; MaxLineLength: integer=0): string; overload;
799 + procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer=0); overload;
800 +
801  
802   implementation
803  
804 + uses FBMessages, Math
805 +
806 + {$IFDEF FPC}
807 + ,RegExpr
808 + {$ELSE}
809 + {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
810 + , RegularExpressions
811 + {$IFEND}
812 + {$ENDIF};
813 +
814 + 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 +
827 +
828   function Max(n1, n2: Integer): Integer;
829   begin
830    if (n1 > n2) then
# Line 311 | Line 866 | begin
866    end;
867   end;
868  
869 < function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
315 < begin
316 <  Value := Trim(Value);
317 <  if Dialect = 1 then
318 <    Value := AnsiUpperCase(Value)
319 <  else
320 <    if (Value <> '') and (Value[1] = '"') then
321 <      Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
322 <    else
323 <      Value := AnsiUpperCase(Value);
324 <  Result := Value;
325 < end;
869 > {Extracts SQL Identifier typically from a  Dialect 3 encoding}
870  
871 < function FormatIdentifierValue(Dialect: Integer; Value: AnsiString): AnsiString;
871 > function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
872   begin
873    Value := Trim(Value);
874    if Dialect = 1 then
# Line 343 | Line 887 | begin
887    Result := Value;
888   end;
889  
890 < function FormatIdentifierValueNC(Dialect: Integer; Value: AnsiString): AnsiString;
890 > {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 <  Value := Trim(Value);
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 > {Returns true if "w" is a Firebird SQL reserved word}
912 >
913 > function IsReservedWord(w: AnsiString): boolean;
914 > var token: TSQLTokens;
915 > begin
916 >  Result := FindReservedWord(w,token);
917 > end;
918 >
919 > {Format an SQL Identifier according to SQL Dialect}
920 >
921 > function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
922 > begin
923 >  Value := TrimRight(Value);
924    if Dialect = 1 then
925      Value := AnsiUpperCase(Value)
926    else
927 <  begin
928 <    if (Value <> '') and (Value[1] = '"') then
927 >    Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
928 >  Result := Value;
929 > end;
930 >
931 > const
932 >  ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
933 >
934 > {Returns true if the value is a valid SQL Identifier - note lower case accepted}
935 >
936 > 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 > 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 > {Extracts the Database Connect string from a Create Database Statement}
965 >
966 > {$IF declared(TRegexpr)}
967 > 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 >      ConnectString := RegexObj.Match[2];
980 >  finally
981 >    RegexObj.Free;
982 >  end;
983 > end;
984 >
985 > function ParseConnectString(ConnectString: AnsiString; var ServerName,
986 >  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
987 >  ): boolean;
988 >
989 > 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 >    RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
1000 >    Result := RegexObj.Exec(ConnectString);
1001 >    if Result then
1002      begin
1003 <      Delete(Value, 1, 1);
1004 <      Delete(Value, Length(Value), 1);
1005 <      Value := AnsiUpperCase(StringReplace (Value, '""', '"', [rfReplaceAll]));
1003 >      {URL type connect string}
1004 >      Protocol := SchemeToProtocol(RegexObj.Match[1]);
1005 >      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 >      if ServerName = '' then
1010 >        DatabaseName := '/' + DatabaseName;
1011      end
1012      else
1013 <      Value := AnsiUpperCase(Value);
1013 >    begin
1014 >      {URL type connect string - local loop}
1015 >      RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
1016 >      Result := RegexObj.Exec(ConnectString);
1017 >      if Result then
1018 >      begin
1019 >        Protocol := SchemeToProtocol(RegexObj.Match[1]);
1020 >        DatabaseName := RegexObj.Match[2];
1021 >      end
1022 >      else
1023 >      begin
1024 >        RegexObj.Expression := '^([a-zA-Z]:\\.*)';
1025 >        Result := RegexObj.Exec(ConnectString);
1026 >        if Result then
1027 >          Protocol := Local {Windows with leading drive ID}
1028 >        else
1029 >        begin
1030 >          RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
1031 >          Result := RegexObj.Exec(ConnectString);
1032 >          if Result then
1033 >          begin
1034 >            {Legacy TCP Format}
1035 >            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 >            Protocol := TCP;
1040 >          end
1041 >          else
1042 >          begin
1043 >            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 >          end;
1060 >        end;
1061 >      end;
1062 >    end;
1063 >  finally
1064 >    RegexObj.Free;
1065    end;
362 –  Result := Value;
1066   end;
1067  
1068 < function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
1068 > {$ELSE}
1069 > {$IF declared(TRegex)}
1070 > function ExtractConnectString(const CreateSQL: AnsiString;
1071 >  var ConnectString: AnsiString): boolean;
1072 > var Regex: TRegEx;
1073 >    Match: TMatch;
1074   begin
1075 <  Value := Trim(Value);
1076 <  if Dialect = 1 then
1077 <    Value := AnsiUpperCase(Value)
1075 >  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 > end;
1082 >
1083 > 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 <    if (Value <> '') and (Value[1] = '"') then
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 <      Delete(Value, 1, 1);
1115 <      Delete(Value, Length(Value), 1);
376 <      Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
1114 >      Protocol := SchemeToProtocol(Match.Groups[1].Value);
1115 >      DatabaseName := Match.Groups[2].Value;
1116      end
1117      else
1118 <      Value := AnsiUpperCase(Value);
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;
381 –  Result := Value;
1156   end;
1157 <
1158 < function IsReservedWord(w: AnsiString): boolean;
1157 > {$ELSE}
1158 > {cruder version of above for Delphi < XE. Older versions lack regular expression
1159 > handling.}
1160 > function ExtractConnectString(const CreateSQL: AnsiString;
1161 >  var ConnectString: AnsiString): boolean;
1162   var i: integer;
1163   begin
1164 <     Result := true;
1165 <     for i := 0 to Length(sqlReservedWords) - 1 do
1166 <         if w = sqlReservedWords[i] then
1167 <            Exit;
1168 <     Result := false;
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  
1179 < function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
1179 > function ParseConnectString(ConnectString: AnsiString;
1180 >              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1181 >              var PortNo: AnsiString): boolean;
1182   begin
1183 <  if Dialect = 1 then
397 <    Value := AnsiUpperCase(Trim(Value))
398 <  else
399 <    Value := '"' + Value + '"';
400 <  Result := Value;
1183 >  Result := false;
1184   end;
1185  
1186 < const
1187 <  ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
1186 > {$IFEND}
1187 > {$IFEND}
1188  
1189 < function IsSQLIdentifier(Value: AnsiString): boolean;
1190 < var i: integer;
1189 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1190 > var ServerName,
1191 >    DatabaseName: AnsiString;
1192 >    PortNo: AnsiString;
1193   begin
1194 <  Result := false;
1195 <  for i := 1 to Length(Value) do
1196 <    if not (Value[i] in ValidSQLIdentifierChars) then Exit;
1197 <  Result := true;
1194 >  if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1195 >    Result := unknownProtocol;
1196 > end;
1197 >
1198 > {Make a connect string in format appropriate protocol}
1199 >
1200 > function MakeConnectString(ServerName, DatabaseName: AnsiString;
1201 >  Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1202 >
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 > begin
1212 >  if ServerName = '' then ServerName := 'localhost';
1213 >  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 >    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 >  end;
1237   end;
1238  
1239 + {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1240 +
1241   function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1242   begin
1243 +  Value := TrimRight(Value);
1244    if (Dialect = 3) and
1245      (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1246 <     Result := '"' + Value + '"'
1246 >     Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
1247    else
1248      Result := Value
1249   end;
1250  
1251 + {Replaces unknown characters in a string with underscores}
1252 +
1253   function Space2Underscore(s: AnsiString): AnsiString;
1254   var
1255     k: integer;
1256   begin
1257       Result := s;
1258       for k := 1 to Length(s) do
1259 <         if not (Result[k] in ['0'..'9','A'..'Z','_','$'])  then
1259 >         if not (Result[k] in ValidSQLIdentifierChars)  then
1260              Result[k] := '_';
1261   end;
1262  
1263 + {Reformats an SQL string with single quotes duplicated.}
1264 +
1265   function SQLSafeString(const s: AnsiString): AnsiString;
1266   begin
1267    Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1268   end;
1269  
1270 + { 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 +      Result := Result + '--' + TokenText + LineEnding;
1313 +
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 + { 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 +      sqltBegin,
1416 +      sqltCase:
1417 +          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 +    '\':
1468 +      Result := sqltBackslash;
1469 +    '*':
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 +    '-':
1488 +      Result := sqltMinus;
1489 +    '<':
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 + 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 +    if GetNext = sqltEOF then Exit;
1621 +    Result := Result + FLastChar;
1622 +  end;
1623 +  GetNext;
1624 + end;
1625 +
1626 + 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 +    if FSkipNext then
1651 +    begin
1652 +      FSkipNext := false;
1653 +      GetNext;
1654 +    end;
1655 +
1656 +    Result := FNextToken;
1657 +    C := FLastChar;
1658 +    GetNext;
1659 +
1660 +    if (Result = sqltCR) and (FNextToken = sqltEOL) then
1661 +    begin
1662 +      FSkipNext := true;
1663 +      Result := sqltEOL;
1664 +      C := LF;
1665 +    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 +        if Result = sqltEOL then
1678 +          FString := FString + LineEnding
1679 +        else
1680 +          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 +        if Result = sqltEOL then
1714 +          FString := FString + LineEnding
1715 +        else
1716 +          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 +        if Result = sqltEOL then
1736 +          FString := FString + LineEnding
1737 +        else
1738 +          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 +          end;
1788 +
1789 +        sqltMinus:
1790 +          begin
1791 +            if FNextToken = sqltMinus then
1792 +            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 +          if FNextToken in [sqltIdentifier,sqltNumberString] then
1813 +            FState := stInIdentifier;
1814 +
1815 +        sqltNumberString:
1816 +          if FNextToken in [sqltNumberString,sqltPeriod] then
1817 +            FState := stInNumeric;
1818 +
1819 +        sqltEOL:
1820 +          FString := LineEnding;
1821 +        end;
1822 +      end;
1823 +    end;
1824 +
1825 + //    writeln(FString);
1826 +    FEOF := Result = sqltEOF;
1827 +  until TokenFound(Result) or EOF;
1828 + end;
1829 +
1830 + 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 + function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
2019 + var i: integer;
2020 +    ds: integer;
2021 +    exponent: integer;
2022 + begin
2023 +  Result := false;
2024 +  ds := 0;
2025 +  exponent := 0;
2026 +  S := Trim(S);
2027 +  Value := 0;
2028 +  scale := 0;
2029 +  if Length(S) = 0 then
2030 +    Exit;
2031 +  {$IF declared(DefaultFormatSettings)}
2032 +  with DefaultFormatSettings do
2033 +  {$ELSE}
2034 +  {$IF declared(FormatSettings)}
2035 +  with FormatSettings do
2036 +  {$IFEND}
2037 +  {$IFEND}
2038 +  begin
2039 +    for i := length(S) downto 1 do
2040 +    begin
2041 +      if S[i] = AnsiChar(DecimalSeparator) then
2042 +      begin
2043 +          if ds <> 0 then Exit; {only one allowed}
2044 +          ds := i;
2045 +          dec(exponent);
2046 +          system.Delete(S,i,1);
2047 +      end
2048 +      else
2049 +      if S[i] in ['+','-'] then
2050 +      begin
2051 +       if (i > 1) and not (S[i-1] in ['e','E']) then
2052 +          Exit; {malformed}
2053 +      end
2054 +      else
2055 +      if S[i] in ['e','E'] then {scientific notation}
2056 +      begin
2057 +        if ds <> 0 then Exit; {not permitted in exponent}
2058 +        if exponent <> 0 then Exit; {only one allowed}
2059 +        exponent := i;
2060 +      end
2061 +      else
2062 +      if not (S[i] in ['0'..'9']) then
2063 +      {Note: ThousandSeparator not allowed by Delphi specs}
2064 +          Exit; {bad character}
2065 +    end;
2066 +
2067 +    if exponent > 0 then
2068 +    begin
2069 +      Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
2070 +      if Result then
2071 +      begin
2072 +        {adjust scale for decimal point}
2073 +        if ds <> 0 then
2074 +          Scale := Scale - (exponent - ds);
2075 +        Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
2076 +      end;
2077 +    end
2078 +    else
2079 +    begin
2080 +      if ds <> 0 then
2081 +        scale := ds - Length(S) - 1;
2082 +      Result := TryStrToInt64(S,Value);
2083 +    end;
2084 +  end;
2085 + end;
2086 +
2087 + function NumericToDouble(aValue: Int64; aScale: integer): double;
2088 + begin
2089 +  Result := aValue * IntPower(10,aScale)
2090 + end;
2091 +
2092 +
2093 + function StringToHex(octetString: string; MaxLineLength: integer): string; overload;
2094 +
2095 +  function ToHex(aValue: byte): string;
2096 +  const
2097 +    HexChars: array [0..15] of char = '0123456789ABCDEF';
2098 +  begin
2099 +    Result := HexChars[aValue shr 4] +
2100 +               HexChars[(aValue and $0F)];
2101 +  end;
2102 +
2103 + var i, j: integer;
2104 + begin
2105 +  i := 1;
2106 +  Result := '';
2107 +  if MaxLineLength = 0 then
2108 +  while i <= Length(octetString) do
2109 +  begin
2110 +    Result := Result +  ToHex(byte(octetString[i]));
2111 +    Inc(i);
2112 +  end
2113 +  else
2114 +  while i <= Length(octetString) do
2115 +  begin
2116 +      for j := 1 to MaxLineLength do
2117 +      begin
2118 +        if i > Length(octetString) then
2119 +          Exit
2120 +        else
2121 +          Result := Result + ToHex(byte(octetString[i]));
2122 +        inc(i);
2123 +      end;
2124 +      Result := Result + LineEnding;
2125 +  end;
2126 + end;
2127 +
2128 + procedure StringToHex(octetString: string; TextOut: TStrings; MaxLineLength: integer); overload;
2129 + begin
2130 +    TextOut.Add(StringToHex(octetString,MaxLineLength));
2131 + end;
2132 +
2133 + { TSQLXMLReader }
2134 +
2135 + function TSQLXMLReader.FindTag(tag: string; var xmlTag: TXMLTag): boolean;
2136 + var i: TXMLTag;
2137 + begin
2138 +  Result := false;
2139 +  for i := xtBlob to xtElt do
2140 +    if XMLTagDefs[i].TagValue = tag then
2141 +    begin
2142 +      xmlTag := XMLTagDefs[i].XMLTag;
2143 +      Result := true;
2144 +      break;
2145 +    end;
2146 + end;
2147 +
2148 + function TSQLXMLReader.GetArrayData(index: integer): TArrayData;
2149 + begin
2150 +  if (index < 0) or (index > ArrayDataCount) then
2151 +    ShowError(sArrayIndexError,[index]);
2152 +  Result := FArrayData[index];
2153 + end;
2154 +
2155 + function TSQLXMLReader.GetArrayDataCount: integer;
2156 + begin
2157 +  Result := Length(FArrayData);
2158 + end;
2159 +
2160 + function TSQLXMLReader.GetBlobData(index: integer): TBlobData;
2161 + begin
2162 +  if (index < 0) or (index > BlobDataCount) then
2163 +    ShowError(sBlobIndexError,[index]);
2164 +  Result := FBlobData[index];
2165 + end;
2166 +
2167 + function TSQLXMLReader.GetBlobDataCount: integer;
2168 + begin
2169 +  Result := Length(FBlobData);
2170 + end;
2171 +
2172 + function TSQLXMLReader.GetTagName(xmltag: TXMLTag): string;
2173 + var i: TXMLTag;
2174 + begin
2175 +  Result := 'unknown';
2176 +  for i := xtBlob to xtElt do
2177 +    if XMLTagDefs[i].XMLTag = xmltag then
2178 +    begin
2179 +      Result := XMLTagDefs[i].TagValue;
2180 +      Exit;
2181 +    end;
2182 + end;
2183 +
2184 + procedure TSQLXMLReader.ProcessAttributeValue(attrValue: string);
2185 + begin
2186 +  case FXMLTagStack[FXMLTagIndex] of
2187 +  xtBlob:
2188 +    if FAttributeName = 'subtype' then
2189 +      FBlobData[FCurrentBlob].SubType := StrToInt(attrValue)
2190 +    else
2191 +      ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2192 +
2193 +  xtArray:
2194 +    if FAttributeName = 'sqltype' then
2195 +      FArrayData[FCurrentArray].SQLType := StrToInt(attrValue)
2196 +    else
2197 +    if FAttributeName = 'relation_name' then
2198 +      FArrayData[FCurrentArray].relationName := attrValue
2199 +    else
2200 +    if FAttributeName = 'column_name' then
2201 +      FArrayData[FCurrentArray].columnName := attrValue
2202 +    else
2203 +    if FAttributeName = 'dim' then
2204 +      FArrayData[FCurrentArray].Dim := StrToInt(attrValue)
2205 +    else
2206 +    if FAttributeName = 'length' then
2207 +      FArrayData[FCurrentArray].Size := StrToInt(attrValue)
2208 +    else
2209 +    if FAttributeName = 'scale' then
2210 +      FArrayData[FCurrentArray].Scale := StrToInt(attrValue)
2211 +    else
2212 +    if FAttributeName = 'charset' then
2213 +      FArrayData[FCurrentArray].CharSet := attrValue
2214 +    else
2215 +    if FAttributeName = 'bounds' then
2216 +      ProcessBoundsList(attrValue)
2217 +    else
2218 +      ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2219 +
2220 +  xtElt:
2221 +    if FAttributeName = 'ix' then
2222 +      with FArrayData[FCurrentArray] do
2223 +        Index[CurrentRow] :=  StrToInt(attrValue)
2224 +     else
2225 +        ShowError(sXMLAttributeError,[FAttributeName,attrValue]);
2226 +  end;
2227 + end;
2228 +
2229 + procedure TSQLXMLReader.ProcessBoundsList(boundsList: string);
2230 + var list: TStringList;
2231 +    i,j: integer;
2232 + begin
2233 +  list := TStringList.Create;
2234 +  try
2235 +    list.Delimiter := ',';
2236 +    list.DelimitedText := boundsList;
2237 +    with FArrayData[FCurrentArray] do
2238 +    begin
2239 +      if dim <> list.Count then
2240 +        ShowError(sInvalidBoundsList,[boundsList]);
2241 +      SetLength(bounds,dim);
2242 +      for i := 0 to list.Count - 1 do
2243 +      begin
2244 +        j := Pos(':',list[i]);
2245 +        if j = 0 then
2246 +          raise Exception.CreateFmt(sInvalidBoundsList,[boundsList]);
2247 +        bounds[i].LowerBound := StrToInt(system.copy(list[i],1,j-1));
2248 +        bounds[i].UpperBound := StrToInt(system.copy(list[i],j+1,length(list[i])-j));
2249 +      end;
2250 +    end;
2251 +  finally
2252 +    list.Free;
2253 +  end;
2254 + end;
2255 +
2256 + procedure TSQLXMLReader.ProcessTagValue(tagValue: string);
2257 +
2258 +  function nibble(hex: char): byte;
2259 +  begin
2260 +    case hex of
2261 +    '0': Result := 0;
2262 +    '1': Result := 1;
2263 +    '2': Result := 2;
2264 +    '3': Result := 3;
2265 +    '4': Result := 4;
2266 +    '5': Result := 5;
2267 +    '6': Result := 6;
2268 +    '7': Result := 7;
2269 +    '8': Result := 8;
2270 +    '9': Result := 9;
2271 +    'a','A': Result := 10;
2272 +    'b','B': Result := 11;
2273 +    'c','C': Result := 12;
2274 +    'd','D': Result := 13;
2275 +    'e','E': Result := 14;
2276 +    'f','F': Result := 15;
2277 +    end;
2278 +  end;
2279 +
2280 +  procedure RemoveWhiteSpace(var hexData: string);
2281 +  var i: integer;
2282 +  begin
2283 +    {Remove White Space}
2284 +    i := 1;
2285 +    while i <= length(hexData) do
2286 +    begin
2287 +      case hexData[i] of
2288 +      ' ',#9,#10,#13:
2289 +        begin
2290 +          if i < Length(hexData) then
2291 +            Move(hexData[i+1],hexData[i],Length(hexData)-i);
2292 +          SetLength(hexData,Length(hexData)-1);
2293 +        end;
2294 +      else
2295 +        Inc(i);
2296 +      end;
2297 +    end;
2298 +  end;
2299 +
2300 +  procedure WriteToBlob(hexData: string);
2301 +  var i,j : integer;
2302 +      blength: integer;
2303 +      P: PByte;
2304 +  begin
2305 +    RemoveWhiteSpace(hexData);
2306 +    if odd(length(hexData)) then
2307 +      ShowError(sBinaryBlockMustbeEven,[nil]);
2308 +    blength := Length(hexData) div 2;
2309 +    ReallocMem(FBlobBuffer,blength);
2310 +    j := 1;
2311 +    P := FBlobBuffer;
2312 +    for i := 1 to blength do
2313 +    begin
2314 +      P^ := (nibble(hexData[j]) shl 4) or nibble(hexdata[j+1]);
2315 +      Inc(j,2);
2316 +      Inc(P);
2317 +    end;
2318 +    FBlobData[FCurrentBlob].BlobIntf.Write(FBlobBuffer^,blength);
2319 +  end;
2320 +
2321 + begin
2322 +  if tagValue = '' then Exit;
2323 +  case FXMLTagStack[FXMLTagIndex] of
2324 +  xtBlob:
2325 +    WriteToBlob(tagValue);
2326 +
2327 +  xtElt:
2328 +    with FArrayData[FCurrentArray] do
2329 +      ArrayIntf.SetAsString(index,tagValue);
2330 +
2331 +  end;
2332 + end;
2333 +
2334 + procedure TSQLXMLReader.XMLTagInit(xmltag: TXMLTag);
2335 + begin
2336 +  if FXMLTagIndex > MaxXMLTags then
2337 +    ShowError(sXMLStackOverFlow,[nil]);
2338 +  Inc(FXMLTagIndex);
2339 +  FXMLTagStack[FXMLTagIndex] := xmltag;
2340 +  FXMLString := '';
2341 +
2342 +  case xmltag of
2343 +  xtBlob:
2344 +    begin
2345 +      Inc(FCurrentBlob);
2346 +      SetLength(FBlobData,FCurrentBlob+1);
2347 +      FBlobData[FCurrentBlob].BlobIntf := nil;
2348 +      FBlobData[FCurrentBlob].SubType := 0;
2349 +    end;
2350 +
2351 +  xtArray:
2352 +    begin
2353 +      Inc(FCurrentArray);
2354 +      SetLength(FArrayData,FCurrentArray+1);
2355 +      with FArrayData[FCurrentArray] do
2356 +      begin
2357 +        ArrayIntf := nil;
2358 +        SQLType := 0;
2359 +        dim := 0;
2360 +        Size := 0;
2361 +        Scale := 0;
2362 +        CharSet := 'NONE';
2363 +        SetLength(Index,0);
2364 +        CurrentRow := -1;
2365 +      end;
2366 +    end;
2367 +
2368 +  xtElt:
2369 +      with FArrayData[FCurrentArray] do
2370 +        Inc(CurrentRow)
2371 +  end;
2372 + end;
2373 +
2374 + function TSQLXMLReader.XMLTagEnd(var xmltag: TXMLTag): boolean;
2375 + begin
2376 +  if FXMLTagIndex = 0 then
2377 +    ShowError(sXMLStackUnderflow,[nil]);
2378 +
2379 +  xmlTag := FXMLTagStack[FXMLTagIndex];
2380 +  case FXMLTagStack[FXMLTagIndex] of
2381 +  xtBlob:
2382 +    FBlobData[FCurrentBlob].BlobIntf.Close;
2383 +
2384 +  xtArray:
2385 +    FArrayData[FCurrentArray].ArrayIntf.SaveChanges;
2386 +
2387 +  xtElt:
2388 +    Dec(FArrayData[FCurrentArray].CurrentRow);
2389 +  end;
2390 +  Dec(FXMLTagIndex);
2391 +  Result := FXMLTagIndex = 0;
2392 + end;
2393 +
2394 + procedure TSQLXMLReader.XMLTagEnter;
2395 + var aCharSetID: integer;
2396 + begin
2397 +  if (Attachment = nil) or not Attachment.IsConnected then
2398 +    ShowError(sNoDatabase);
2399 +  if Transaction = nil then
2400 +    ShowError(sNoTransaction);
2401 +  case FXMLTagStack[FXMLTagIndex] of
2402 +  xtBlob:
2403 +    begin
2404 +      if not Transaction.InTransaction then
2405 +        Transaction.Start;
2406 +      FBlobData[FCurrentBlob].BlobIntf := Attachment.CreateBlob(
2407 +        Transaction,FBlobData[FCurrentBlob].SubType);
2408 +    end;
2409 +
2410 +  xtArray:
2411 +    with FArrayData[FCurrentArray] do
2412 +    begin
2413 +      if not Transaction.InTransaction then
2414 +        Transaction.Start;
2415 +      Attachment.CharSetName2CharSetID(CharSet,aCharSetID);
2416 +      SetLength(Index,dim);
2417 +      ArrayIntf := Attachment.CreateArray(
2418 +                     Transaction,
2419 +                     Attachment.CreateArrayMetaData(SQLType,
2420 +                       relationName,columnName,Scale,Size,
2421 +                       aCharSetID,dim,bounds)
2422 +                     );
2423 +    end;
2424 +  end;
2425 + end;
2426 +
2427 + {This is where the XML tags are identified and the token stream modified in
2428 + consequence}
2429 +
2430 + function TSQLXMLReader.TokenFound(var token: TSQLTokens): boolean;
2431 +
2432 + procedure NotAnXMLTag;
2433 + begin
2434 +   begin
2435 +     if FXMLTagIndex = 0 then
2436 +     {nothing to do with XML so go back to processing SQL}
2437 +     begin
2438 +       QueueToken(token);
2439 +       ReleaseQueue(token);
2440 +       FXMLState := stNoXML
2441 +     end
2442 +     else
2443 +     begin
2444 +       {Not an XML tag, so just push back to XML Data}
2445 +       FXMLState := stXMLData;
2446 +       FXMLString := FXMLString + GetQueuedText;
2447 +       ResetQueue;
2448 +     end;
2449 +   end;
2450 + end;
2451 +
2452 + var XMLTag: TXMLTag;
2453 + begin
2454 +  Result := inherited TokenFound(token);
2455 +  if not Result then Exit;
2456 +
2457 +  case FXMLState of
2458 +  stNoXML:
2459 +    if token = sqltLT then
2460 +    begin
2461 +      ResetQueue;
2462 +      QueueToken(token); {save in case this is not XML}
2463 +      FXMLState := stInTag;
2464 +    end;
2465 +
2466 +  stInTag:
2467 +    {Opening '<' found, now looking for tag name or end tag marker}
2468 +    case token of
2469 +    sqltIdentifier:
2470 +      begin
2471 +        if FindTag(TokenText,XMLTag) then
2472 +        begin
2473 +          XMLTagInit(XMLTag);
2474 +          QueueToken(token);
2475 +          FXMLState := stInTagBody;
2476 +        end
2477 +        else
2478 +          NotAnXMLTag;
2479 +      end;
2480 +
2481 +    sqltForwardSlash:
2482 +      FXMLState := stInEndTag;
2483 +
2484 +    else
2485 +      NotAnXMLTag;
2486 +    end {case token};
2487 +
2488 +  stInTagBody:
2489 +    {Tag name found. Now looking for attribute or closing '>'}
2490 +    case token of
2491 +    sqltIdentifier:
2492 +      begin
2493 +        FAttributeName := TokenText;
2494 +        QueueToken(token);
2495 +        FXMLState := stAttribute;
2496 +      end;
2497 +
2498 +    sqltGT:
2499 +      begin
2500 +        ResetQueue;
2501 +        XMLTagEnter;
2502 +        FXMLState := stXMLData;
2503 +      end;
2504 +
2505 +    sqltSpace,
2506 +    sqltEOL:
2507 +      QueueToken(token);
2508 +
2509 +    else
2510 +      NotAnXMLTag;
2511 +    end {case token};
2512 +
2513 +  stAttribute:
2514 +    {Attribute name found. Must be followed by an '=', a '>' or another tag name}
2515 +    case token of
2516 +      sqltEquals:
2517 +      begin
2518 +        QueueToken(token);
2519 +        FXMLState := stAttributeValue;
2520 +      end;
2521 +
2522 +      sqltSpace,
2523 +      sqltEOL:
2524 +        QueueToken(token);
2525 +
2526 +      sqltIdentifier:
2527 +        begin
2528 +          ProcessAttributeValue('');
2529 +          FAttributeName := TokenText;
2530 +          QueueToken(token);
2531 +          FXMLState := stAttribute;
2532 +        end;
2533 +
2534 +      sqltGT:
2535 +        begin
2536 +          ProcessAttributeValue('');
2537 +          ResetQueue;
2538 +          XMLTagEnter;
2539 +          FXMLState := stXMLData;
2540 +        end;
2541 +
2542 +      else
2543 +        NotAnXMLTag;
2544 +    end; {case token}
2545 +
2546 +  stAttributeValue:
2547 +    {Looking for attribute value as a single identifier or a double quoted value}
2548 +    case token of
2549 +    sqltIdentifier,sqltIdentifierInDoubleQuotes:
2550 +      begin
2551 +        ProcessAttributeValue(TokenText);
2552 +        QueueToken(token);
2553 +        FXMLState := stInTagBody;
2554 +      end;
2555 +
2556 +    sqltSpace,
2557 +    sqltEOL:
2558 +      QueueToken(token);
2559 +
2560 +    else
2561 +      NotAnXMLTag;
2562 +    end; {case token}
2563 +
2564 +  stXMLData:
2565 +    if token = sqltLT then
2566 +    begin
2567 +      QueueToken(token); {save in case this is not XML}
2568 +      FXMLState := stInTag;
2569 +    end
2570 +    else
2571 +      FXMLString := FXMLString + TokenText;
2572 +
2573 +  stInEndTag:
2574 +    {Opening '</' found, now looking for tag name}
2575 +    case token of
2576 +    sqltIdentifier:
2577 +      begin
2578 +        if FindTag(TokenText,XMLTag) and (XMLTag = FXMLTagStack[FXMLTagIndex]) then
2579 +        begin
2580 +          QueueToken(token);
2581 +          FXMLState := stInEndTagBody;
2582 +        end
2583 +        else
2584 +          ShowError(sInvalidEndTag,[TokenText]);
2585 +      end;
2586 +    else
2587 +      NotAnXMLTag;
2588 +    end {case token};
2589 +
2590 +  stInEndTagBody:
2591 +  {End tag name found, now looping for closing '>'}
2592 +    case Token of
2593 +    sqltGT:
2594 +      begin
2595 +        ProcessTagValue(FXMLString);
2596 +        if XMLTagEnd(XMLTag) then
2597 +        begin
2598 +          ResetQueue;
2599 +          QueueToken(sqltColon,':');
2600 +          case XMLTag of
2601 +            xtBlob:
2602 +              QueueToken(sqltIdentifier,Format(ibx_blob+'%d',[FCurrentBlob]));
2603 +
2604 +            xtArray:
2605 +              QueueToken(sqltIdentifier, Format(ibx_array+'%d',[FCurrentArray]));
2606 +          end;
2607 +          ReleaseQueue(token);
2608 +          FXMLState := stNoXML;
2609 +       end
2610 +       else
2611 +         FXMLState := stXMLData;
2612 +      end;
2613 +
2614 +    sqltSpace,
2615 +    sqltEOL:
2616 +      QueueToken(token);
2617 +
2618 +    else
2619 +      ShowError(sBadEndTagClosing);
2620 +    end; {case token}
2621 +
2622 +  end {Case FState};
2623 +
2624 +  {Only allow token to be returned if not processing an XML tag}
2625 +
2626 +  Result := FXMLState = stNoXML;
2627 + end;
2628 +
2629 + procedure TSQLXMLReader.ShowError(msg: string; params: array of const);
2630 + begin
2631 +  raise EIBClientError.CreateFmt(GetErrorPrefix + msg,params);
2632 + end;
2633 +
2634 + procedure TSQLXMLReader.ShowError(msg: string);
2635 + begin
2636 +  ShowError(msg,[nil]);
2637 + end;
2638 +
2639 + constructor TSQLXMLReader.Create;
2640 + begin
2641 +  inherited;
2642 +  FXMLState := stNoXML;
2643 + end;
2644 +
2645 + procedure TSQLXMLReader.FreeDataObjects;
2646 + begin
2647 +  FXMLTagIndex := 0;
2648 +  SetLength(FBlobData,0);
2649 +  FCurrentBlob := -1;
2650 +  SetLength(FArrayData,0);
2651 +  FCurrentArray := -1;
2652 + end;
2653 +
2654 + class function TSQLXMLReader.FormatBlob(Field: ISQLData): string;
2655 + begin
2656 +  Result := FormatBlob(Field.AsString,Field.getSubtype);
2657 + end;
2658 +
2659 + class function TSQLXMLReader.FormatBlob(contents: string; subtype: integer
2660 +  ): string;
2661 + var TextOut: TStrings;
2662 + begin
2663 +  TextOut := TStringList.Create;
2664 +  try
2665 +    TextOut.Add(Format('<blob subtype="%d">',[subtype]));
2666 +    StringToHex(contents,TextOut,BlobLineLength);
2667 +    TextOut.Add('</blob>');
2668 +    Result := TextOut.Text;
2669 +  finally
2670 +    TextOut.Free;
2671 +  end;
2672 + end;
2673 +
2674 +
2675 + class function TSQLXMLReader.FormatArray(ar: IArray
2676 +  ): string;
2677 + var index: array of integer;
2678 +    TextOut: TStrings;
2679 +
2680 +    procedure AddElements(dim: integer; indent:string = ' ');
2681 +    var i: integer;
2682 +        recurse: boolean;
2683 +    begin
2684 +      SetLength(index,dim+1);
2685 +      recurse := dim < ar.GetDimensions - 1;
2686 +      with ar.GetBounds[dim] do
2687 +      for i := LowerBound to UpperBound do
2688 +      begin
2689 +        index[dim] := i;
2690 +        if recurse then
2691 +        begin
2692 +          TextOut.Add(Format('%s<elt id="%d">',[indent,i]));
2693 +          AddElements(dim+1,indent + ' ');
2694 +          TextOut.Add('</elt>');
2695 +        end
2696 +        else
2697 +        if ((ar.GetSQLType = SQL_TEXT) or (ar.GetSQLType = SQL_VARYING)) and
2698 +           (ar.GetCharSetID = 1) then
2699 +           TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,StringToHex(ar.GetAsString(index))]))
2700 +        else
2701 +          TextOut.Add(Format('%s<elt ix="%d">%s</elt>',[indent,i,ar.GetAsString(index)]));
2702 +      end;
2703 +    end;
2704 +
2705 + var
2706 +    s: string;
2707 +    bounds: TArrayBounds;
2708 +    i: integer;
2709 +    boundsList: string;
2710 + begin
2711 +  TextOut := TStringList.Create;
2712 +  try
2713 +    if ar.GetCharSetWidth = 0 then
2714 +      s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2715 +                              [ar.GetDimensions,ar.GetSQLType,ar.GetSize,
2716 +                               ar.GetTableName,ar.GetColumnName])
2717 +    else
2718 +      s := Format('<array dim = "%d" sqltype = "%d" length = "%d" relation_name = "%s" column_name = "%s"',
2719 +                                [ar.GetDimensions,ar.GetSQLType,ar.GetSize div ar.GetCharSetWidth,
2720 +                                 ar.GetTableName,ar.GetColumnName]);
2721 +    case ar.GetSQLType of
2722 +    SQL_DOUBLE, SQL_FLOAT, SQL_LONG, SQL_SHORT, SQL_D_FLOAT, SQL_INT64:
2723 +       s := s + Format(' scale = "%d"',[ ar.GetScale]);
2724 +    SQL_TEXT,
2725 +    SQL_VARYING:
2726 +      s := s + Format(' charset = "%s"',[ar.GetAttachment.GetCharsetName(ar.GetCharSetID)]);
2727 +    end;
2728 +    bounds := ar.GetBounds;
2729 +    boundsList := '';
2730 +    for i := 0 to length(bounds) - 1 do
2731 +    begin
2732 +      if i <> 0 then boundsList := boundsList + ',';
2733 +      boundsList := boundsList + Format('%d:%d',[bounds[i].LowerBound,bounds[i].UpperBound]);
2734 +    end;
2735 +    s := s + Format(' bounds="%s"',[boundsList]);
2736 +    s := s + '>';
2737 +    TextOut.Add(s);
2738 +
2739 +    SetLength(index,0);
2740 +    AddElements(0);
2741 +    TextOut.Add('</array>');
2742 +    Result := TextOut.Text;
2743 +  finally
2744 +    TextOut.Free;
2745 +  end;
2746 + end;
2747 +
2748 + procedure TSQLXMLReader.Reset;
2749 + begin
2750 +  inherited Reset;
2751 +  FreeDataObjects;
2752 +  FXMLString := '';
2753 +  FreeMem(FBlobBuffer);
2754 + end;
2755 +
2756 + { TJournalProcessor }
2757 +
2758 + procedure TJournalProcessor.DoExecute;
2759 + var token: TSQLTokens;
2760 +    LineState: TLineState;
2761 +    JnlEntry: TJnlEntry;
2762 +    Len: integer;
2763 +    tz: AnsiString;
2764 +
2765 +  procedure ClearJnlEntry;
2766 +  begin
2767 +    with JnlEntry do
2768 +    begin
2769 +      TransactionName := '';
2770 +      TPB := nil;
2771 +      QueryText :='';
2772 +      JnlEntryType := jeUnknown;
2773 +      SessionID := 0;
2774 +      TransactionID := 0;
2775 +      DefaultCompletion := taCommit;
2776 +    end;
2777 +  end;
2778 +
2779 +  function CreateTPB(TPBText: AnsiString): ITPB;
2780 +  var index: integer;
2781 +  begin
2782 +    Result := nil;
2783 +    if Length(TPBText) = 0 then
2784 +      Exit;
2785 +    Result := FFirebirdClientAPI.AllocateTPB;
2786 +    try
2787 +      index := Pos('[',TPBText);
2788 +      if index > 0 then
2789 +        system.Delete(TPBText,1,index);
2790 +      repeat
2791 +        index := Pos(',',TPBText);
2792 +        if index = 0 then
2793 +        begin
2794 +          index := Pos(']',TPBText);
2795 +          if index <> 0 then
2796 +            system.Delete(TPBText,index,1);
2797 +          Result.AddByTypeName(TPBText);
2798 +          break;
2799 +        end;
2800 +        Result.AddByTypeName(system.copy(TPBText,1,index-1));
2801 +        system.Delete(TPBText,1,index);
2802 +      until false;
2803 +    except
2804 +      Result := nil;
2805 +      raise;
2806 +    end;
2807 +  end;
2808 +
2809 + begin
2810 +  LineState := lsInit;
2811 +  JnlEntry.JnlEntryType := jeUnknown;
2812 +  while not EOF do
2813 +  begin
2814 +    if LineState = lsInit then
2815 +      ClearJnlEntry;
2816 +    token := GetNextToken;
2817 +    with JnlEntry do
2818 +    case token of
2819 +    sqltAsterisk:
2820 +      if LineState = lsInit then
2821 +        LineState := lsJnlFound;
2822 +
2823 +    sqltIdentifier:
2824 +      if LineState = lsJnlFound then
2825 +        begin
2826 +          JnlEntryType := IdentifyJnlEntry(TokenText);
2827 +          LineState := lsGotJnlType;
2828 +        end
2829 +      else
2830 +        LineState := lsInit;
2831 +
2832 +    sqltQuotedString:
2833 +      if (LineState = lsGotJnlType)
2834 +          and ParseDateTimeTZString(TokenText,TimeStamp,tz) then
2835 +            LineState := lsGotTimestamp
2836 +      else
2837 +        LineState := lsInit;
2838 +
2839 +    sqltColon:
2840 +      case LineState of
2841 +      lsGotText1Length:
2842 +        begin
2843 +          if Len > 0 then
2844 +          begin
2845 +            if JnlEntryType = jeTransStart then
2846 +              TransactionName := ReadCharacters(Len)
2847 +            else
2848 +              QueryText := ReadCharacters(Len)
2849 +          end;
2850 +          if JnlEntryType = jeTransStart then
2851 +             LineState := lsGotText1
2852 +          else
2853 +          begin
2854 +            if assigned(FOnNextJournalEntry) then
2855 +              OnNextJournalEntry(JnlEntry);
2856 +            LineState := lsInit;
2857 +          end
2858 +        end;
2859 +
2860 +      lsGotText2Length:
2861 +        begin
2862 +          if Len > 0 then
2863 +            TPB :=  CreateTPB(ReadCharacters(Len));
2864 +          LineState := lsGotText2;
2865 +        end;
2866 +
2867 +      else
2868 +      if LineState <> lsGotJnlType then
2869 +        LineState := lsInit;
2870 +    end;
2871 +
2872 +   sqltComma:
2873 +     if not (LineState in [lsGotTimestamp,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2874 +       LineState := lsInit;
2875 +
2876 +   sqltNumberString:
2877 +     case LineState of
2878 +     lsGotTimestamp:
2879 +       begin
2880 +         SessionID := StrToInt(TokenText);
2881 +         LineState := lsGotSessionID;
2882 +       end;
2883 +
2884 +     lsGotSessionID:
2885 +       begin
2886 +         TransactionID := StrToInt(TokenText);
2887 +         if JnlEntryType in [jeTransCommit, jeTransRollback] then
2888 +         begin
2889 +           if assigned(FOnNextJournalEntry) then
2890 +             OnNextJournalEntry(JnlEntry);
2891 +           LineState := lsInit;
2892 +         end
2893 +         else
2894 +           LineState := lsGotTransactionID;
2895 +       end;
2896 +
2897 +     lsGotTransactionID:
2898 +       begin
2899 +         case JnlEntryType of
2900 +         jeTransStart:
2901 +           begin
2902 +             len := StrToInt(TokenText);
2903 +             LineState := lsGotText1Length;
2904 +           end;
2905 +
2906 +         jeQuery:
2907 +           begin
2908 +             len :=  StrToInt(TokenText);
2909 +             LineState := lsGotText1Length;
2910 +           end;
2911 +
2912 +         jeTransCommitRet,
2913 +         jeTransRollbackRet:
2914 +           begin
2915 +             OldTransactionID := StrToInt(TokenText);
2916 +             if assigned(FOnNextJournalEntry) then
2917 +               OnNextJournalEntry(JnlEntry);
2918 +             LineState := lsInit;
2919 +           end;
2920 +
2921 +           else
2922 +             LineState := lsInit;
2923 +         end; {case JnlEntryType}
2924 +
2925 +       end;
2926 +
2927 +     lsGotText1:
2928 +       begin
2929 +         len := StrToInt(TokenText);
2930 +         LineState := lsGotText2Length;
2931 +       end;
2932 +
2933 +     lsGotText2:
2934 +        begin
2935 +          if JnlEntryType = jeTransStart then
2936 +          begin
2937 +            DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2938 +            if assigned(FOnNextJournalEntry) then
2939 +              OnNextJournalEntry(JnlEntry);
2940 +          end;
2941 +          LineState := lsInit;
2942 +        end;
2943 +     end; {case LineState}
2944 +    end; {case token}
2945 +  end; {while}
2946 +  ClearJnlEntry;
2947 + end;
2948 +
2949 + function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2950 +  ): TJnlEntryType;
2951 + begin
2952 +  Result := jeUnknown;
2953 +  if Length(aTokenText) > 0 then
2954 +  case aTokenText[1] of
2955 +  'S':
2956 +    Result := jeTransStart;
2957 +  'C':
2958 +    Result := jeTransCommit;
2959 +  'c':
2960 +    Result := jeTransCommitRet;
2961 +  'R':
2962 +    Result := jeTransRollback;
2963 +  'r':
2964 +    Result := jeTransRollbackRet;
2965 +  'E':
2966 +    Result := jeTransEnd;
2967 +  'Q':
2968 +    Result := jeQuery;
2969 +  end;
2970 + end;
2971 +
2972 + class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2973 + begin
2974 +  case je of
2975 +  jeTransStart:
2976 +    Result := 'Transaction Start';
2977 +  jeTransCommit:
2978 +    Result := 'Commit';
2979 +  jeTransCommitRet:
2980 +    Result := 'Commit Retaining';
2981 +  jeTransRollback:
2982 +    Result := 'Rollback';
2983 +  jeTransRollbackRet:
2984 +    Result := 'Rollback Retaining';
2985 +  jeTransEnd:
2986 +    Result := 'Transaction End';
2987 +  jeQuery:
2988 +    Result := 'Query';
2989 +  jeUnknown:
2990 +    Result := 'Unknown';
2991 +  end;
2992 + end;
2993 +
2994 + function TJournalProcessor.GetChar: AnsiChar;
2995 + begin
2996 +  if FInStream.Read(Result,1) = 0 then
2997 +    Result := #0;
2998 + end;
2999 +
3000 + destructor TJournalProcessor.Destroy;
3001 + begin
3002 +  FInStream.Free;
3003 +  inherited Destroy;
3004 + end;
3005 +
3006 + class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
3007 +  aOnNextJournalEntry: TOnNextJournalEntry);
3008 + begin
3009 +  with TJournalProcessor.Create do
3010 +  try
3011 +    FInStream := TFileStream.Create(aFileName,fmOpenRead);
3012 +    FFirebirdClientAPI := api;
3013 +    OnNextJournalEntry := aOnNextJournalEntry;
3014 +    DoExecute;
3015 +  finally
3016 +    Free
3017 +  end;
3018 + end;
3019 +
3020 +
3021   end.

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines