ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/branches/udr/client/IBUtils.pas

Comparing:
ibx/trunk/fbintf/IBUtils.pas (file contents), Revision 117 by tony, Mon Jan 22 13:58:11 2018 UTC vs.
ibx/branches/udr/client/IBUtils.pas (file contents), Revision 394 by tony, Sat Feb 12 23:26:48 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, jeTransCommitFail, jeTransCommitRet, jeTransRollback,
724	+	jeTransRollbackFail, jeTransRollbackRet, 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;
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 RegExpr;
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
#	Line 332 | Line 887 | begin
887		Result := Value;
888		end;
889
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	+	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 i: integer;
914	>	var token: TSQLTokens;
915		begin
916	<	Result := true;
341	<	for i := 0 to Length(sqlReservedWords) - 1 do
342	<	if w = sqlReservedWords[i] then
343	<	Exit;
344	<	Result := false;
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(Trim(Value))
925	>	Value := AnsiUpperCase(Value)
926		else
927		Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
928		Result := Value;
#	Line 369 | Line 942 | begin
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;
#	Line 383 | Line 976 | begin
976		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
977		Result := RegexObj.Exec(CreateSQL);
978		if Result then
979	<	ConnectString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
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	+	{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	+	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;
1066	+	end;
1067	+
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	+	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	+	{URL type connect string - local loop}
1110	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
1111	+	Result := Match.Success and (Match.Groups.Count = 3);
1112	+	if Result then
1113	+	begin
1114	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
1115	+	DatabaseName := Match.Groups[2].Value;
1116	+	end
1117	+	else
1118	+	begin
1119	+	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
1120	+	Result := Match.Success;
1121	+	if Result then
1122	+	Protocol := Local {Windows with leading drive ID}
1123	+	else
1124	+	begin
1125	+	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
1126	+	Result := Match.Success and (Match.Groups.Count = 4);
1127	+	if Result then
1128	+	begin
1129	+	{Legacy TCP Format}
1130	+	ServerName := Match.Groups[1].Value;
1131	+	PortNo := Match.Groups[2].Value;
1132	+	DatabaseName := Match.Groups[3].Value;
1133	+	Protocol := TCP;
1134	+	end
1135	+	else
1136	+	begin
1137	+	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
1138	+	Result := Match.Success and (Match.Groups.Count = 4);
1139	+	if Result then
1140	+	begin
1141	+	{Netbui}
1142	+	ServerName := Match.Groups[1].Value;
1143	+	PortNo := Match.Groups[2].Value;
1144	+	DatabaseName := Match.Groups[3].Value;
1145	+	Protocol := NamedPipe
1146	+	end
1147	+	else
1148	+	begin
1149	+	Result := true;
1150	+	Protocol := Local; {Assume local}
1151	+	end;
1152	+	end;
1153	+	end;
1154	+	end;
1155	+	end;
1156	+	end;
1157	+	{$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 := 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 ParseConnectString(ConnectString: AnsiString;
1180	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1181	+	var PortNo: AnsiString): boolean;
1182	+	begin
1183	+	Result := false;
1184	+	end;
1185	+
1186	+	{$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		(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1246		Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
#	Line 419 | Line 1267 | 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, jeTransCommitFail, jeTransRollback, jeTransRollbackFail] 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	+	jeTransCommitFail,
2845	+	jeTransRollbackFail,
2846	+	jeTransRollbackRet:
2847	+	begin
2848	+	OldTransactionID := StrToInt(TokenText);
2849	+	if assigned(FOnNextJournalEntry) then
2850	+	OnNextJournalEntry(JnlEntry);
2851	+	LineState := lsInit;
2852	+	end;
2853	+
2854	+	else
2855	+	LineState := lsInit;
2856	+	end; {case JnlEntryType}
2857	+
2858	+	end;
2859	+
2860	+	lsGotText1:
2861	+	begin
2862	+	len := StrToInt(TokenText);
2863	+	LineState := lsGotText2Length;
2864	+	end;
2865	+
2866	+	lsGotText2:
2867	+	begin
2868	+	if JnlEntryType = jeTransStart then
2869	+	begin
2870	+	DefaultCompletion := TTransactionCompletion(StrToInt(TokenText));
2871	+	if assigned(FOnNextJournalEntry) then
2872	+	OnNextJournalEntry(JnlEntry);
2873	+	end;
2874	+	LineState := lsInit;
2875	+	end;
2876	+	end; {case LineState}
2877	+	end; {case token}
2878	+	end; {while}
2879	+	ClearJnlEntry;
2880	+	end;
2881	+
2882	+	function TJournalProcessor.IdentifyJnlEntry(aTokenText: AnsiString
2883	+	): TJnlEntryType;
2884	+	begin
2885	+	Result := jeUnknown;
2886	+	if Length(aTokenText) > 0 then
2887	+	case aTokenText[1] of
2888	+	'S':
2889	+	Result := jeTransStart;
2890	+	'C':
2891	+	Result := jeTransCommit;
2892	+	'c':
2893	+	Result := jeTransCommitRet;
2894	+	'R':
2895	+	Result := jeTransRollback;
2896	+	'r':
2897	+	Result := jeTransRollbackRet;
2898	+	'Q':
2899	+	Result := jeQuery;
2900	+	'F':
2901	+	Result := jeTransCommitFail;
2902	+	'f':
2903	+	Result := jeTransRollbackFail;
2904	+	end;
2905	+	end;
2906	+
2907	+	class function TJournalProcessor.JnlEntryText(je: TJnlEntryType): string;
2908	+	begin
2909	+	case je of
2910	+	jeTransStart:
2911	+	Result := 'Transaction Start';
2912	+	jeTransCommit:
2913	+	Result := 'Commit';
2914	+	jeTransCommitFail:
2915	+	Result := 'Commit (Failed)';
2916	+	jeTransCommitRet:
2917	+	Result := 'Commit Retaining';
2918	+	jeTransRollback:
2919	+	Result := 'Rollback';
2920	+	jeTransRollbackFail:
2921	+	Result := 'Rollback (Failed)';
2922	+	jeTransRollbackRet:
2923	+	Result := 'Rollback Retaining';
2924	+	jeQuery:
2925	+	Result := 'Query';
2926	+	jeUnknown:
2927	+	Result := 'Unknown';
2928	+	end;
2929	+	end;
2930	+
2931	+	function TJournalProcessor.GetChar: AnsiChar;
2932	+	begin
2933	+	if FInStream.Read(Result,1) = 0 then
2934	+	Result := #0;
2935	+	end;
2936	+
2937	+	destructor TJournalProcessor.Destroy;
2938	+	begin
2939	+	FInStream.Free;
2940	+	inherited Destroy;
2941	+	end;
2942	+
2943	+	class procedure TJournalProcessor.Execute(aFileName: string; api: IFirebirdAPI;
2944	+	aOnNextJournalEntry: TOnNextJournalEntry);
2945	+	begin
2946	+	with TJournalProcessor.Create do
2947	+	try
2948	+	FInStream := TFileStream.Create(aFileName,fmOpenRead);
2949	+	FFirebirdClientAPI := api;
2950	+	OnNextJournalEntry := aOnNextJournalEntry;
2951	+	DoExecute;
2952	+	finally
2953	+	Free
2954	+	end;
2955	+	end;
2956	+
2957	+
2958		end.

Comparing:
ibx/trunk/fbintf/IBUtils.pas (property svn:eol-style), Revision 117 by tony, Mon Jan 22 13:58:11 2018 UTC vs.
ibx/branches/udr/client/IBUtils.pas (property svn:eol-style), Revision 394 by tony, Sat Feb 12 23:26:48 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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