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

Comparing:
ibx/trunk/fbintf/IBUtils.pas (file contents), Revision 56 by tony, Mon Mar 6 10:20:02 2017 UTC vs.
ibx/branches/udr/client/IBUtils.pas (file contents), Revision 379 by tony, Mon Jan 10 10:08:03 2022 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 +   AttachmentID: cardinal;
730 +   SessionID: cardinal;
731 +   TransactionID: cardinal;
732 +   OldTransactionID: cardinal;
733 +   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 +      type TLineState = (lsInit, lsJnlFound, lsGotTimestamp, lsGotJnlType,
746 +                          lsGotAttachmentID, lsGotSessionID,
747 +                          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   function Max(n1, n2: Integer): Integer;
766   function Min(n1, n2: Integer): Integer;
767   function RandomString(iLength: Integer): AnsiString;
768   function RandomInteger(iLow, iHigh: Integer): Integer;
769   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;
770   function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
771 + function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
772 + function IsReservedWord(w: AnsiString): boolean;
773   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 + function IsSQLIdentifier(Value: AnsiString): boolean;
778 + function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
779 + 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 +
786 + {$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 + 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 310 | Line 866 | begin
866    end;
867   end;
868  
869 < function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
314 < begin
315 <  Value := Trim(Value);
316 <  if Dialect = 1 then
317 <    Value := AnsiUpperCase(Value)
318 <  else
319 <    if (Value <> '') and (Value[1] = '"') then
320 <      Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
321 <    else
322 <      Value := AnsiUpperCase(Value);
323 <  Result := Value;
324 < 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 342 | 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;
361 –  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);
375 <      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;
380 –  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
396 <    Value := AnsiUpperCase(Trim(Value))
397 <  else
398 <    Value := '"' + Value + '"';
399 <  Result := Value;
1183 >  Result := false;
1184   end;
1185  
1186 + {$IFEND}
1187 + {$IFEND}
1188 +
1189 + 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 + {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 <    ((AnsiUpperCase(Value) <> Value) or IsReservedWord(Value)) then
1246 <     Result := '"' + Value + '"'
1245 >    (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
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 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 +     if not (LineState in [lsGotTimestamp,lsGotAttachmentID,lsGotSessionID,lsGotTransactionID,lsGotText1,lsGotText2]) then
2799 +       LineState := lsInit;
2800 +
2801 +   sqltNumberString:
2802 +     case LineState of
2803 +     lsGotTimestamp:
2804 +       begin
2805 +         AttachmentID := StrToInt(TokenText);
2806 +         LineState := lsGotAttachmentID;
2807 +       end;
2808 +
2809 +     lsGotAttachmentID:
2810 +       begin
2811 +         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   end.

Comparing:
ibx/trunk/fbintf/IBUtils.pas (property svn:eol-style), Revision 56 by tony, Mon Mar 6 10:20:02 2017 UTC vs.
ibx/branches/udr/client/IBUtils.pas (property svn:eol-style), Revision 379 by tony, Mon Jan 10 10:08:03 2022 UTC

# Line 0 | Line 1
1 + native

Diff Legend

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