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 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
ibx/branches/udr/client/IBUtils.pas (file contents), Revision 379 by tony, Mon Jan 10 10:08:03 2022 UTC

#	Line 32 | Line 32
32		{************************************************************************}
33
34		unit IBUtils;
35	+	{$IFDEF MSWINDOWS}
36	+	{$DEFINE WINDOWS}
37	+	{$ENDIF}
38
39		{$IFDEF FPC}
40		{$Mode Delphi}
41		{$codepage UTF8}
42		{$ENDIF}
43
44	+	{ $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45	+	{ $define HASDELPHIREQEX}
46	+	{ $IFEND}
47	+
48		interface
49
50	<	uses
51	<	{$IFDEF WINDOWS }
52	<	Windows,
53	<	{$ELSE}
54	<	unix,
55	<	{$ENDIF}
56	<	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 55 | Line 310 | const
310		TAB  = #9;
311		NULL_TERMINATOR = #0;
312
313	<	sqlReservedWords: array [0..166] of string = (
314	<	'ADD','ADMIN','ALL','ALTER','AND','ANY','AS','AT','AVG','BEGIN','BETWEEN','BIGINT','BIT_LENGTH','BLOB','BOTH',
315	<	'BY','CASE','CAST','CHAR','CHAR_LENGTH','CHARACTER','CHARACTER_LENGTH','CHECK','CLOSE','COLLATE','COLUMN',
316	<	'COMMIT','CONNECT','CONSTRAINT','COUNT','CREATE','CROSS','CURRENT','CURRENT_CONNECTION','CURRENT_DATE',
317	<	'CURRENT_ROLE','CURRENT_TIME','CURRENT_TIMESTAMP','CURRENT_TRANSACTION','CURRENT_USER','CURSOR','DATE',
318	<	'DAY','DEC','DECIMAL','DECLARE','DEFAULT','DELETE','DISCONNECT','DISTINCT','DOUBLE','DROP','ELSE','END',
319	<	'ESCAPE','EXECUTE','EXISTS','EXTERNAL','EXTRACT','FETCH','FILTER','FLOAT','FOR','FOREIGN','FROM','FULL',
320	<	'FUNCTION','GDSCODE','GLOBAL','GRANT','GROUP','HAVING','HOUR','IN','INDEX','INNER','INSENSITIVE','INSERT',
321	<	'INT','INTEGER','INTO','IS','JOIN','LEADING','LEFT','LIKE','LONG','LOWER','MAX','MAXIMUM_SEGMENT','MERGE',
322	<	'MIN','MINUTE','MONTH','NATIONAL','NATURAL','NCHAR','NO','NOT','NULL','NUMERIC','OCTET_LENGTH','OF','ON',
323	<	'ONLY','OPEN','OR','ORDER','OUTER','PARAMETER','PLAN','POSITION','POST_EVENT','PRECISION','PRIMARY',
324	<	'PROCEDURE','RDB$DB_KEY','REAL','RECORD_VERSION','RECREATE','RECURSIVE','REFERENCES','RELEASE','RETURNING_VALUES',
325	<	'RETURNS','REVOKE','RIGHT','ROLLBACK','ROW_COUNT','ROWS','SAVEPOINT','SECOND','SELECT','SENSITIVE',
326	<	'SET','SIMILAR','SMALLINT','SOME','SQLCODE','SQLSTATE','START','SUM','TABLE','THEN','TIME',
327	<	'TIMESTAMP','TO','TRAILING','TRIGGER','TRIM','UNION','UNIQUE','UPDATE','UPPER','USER','USING',
328	<	'VALUE','VALUES','VARCHAR','VARIABLE','VARYING','VIEW','WHEN','WHERE','WHILE','WITH','YEAR');
313	>	{SQL Reserved words in alphabetical order}
314	>
315	>	sqlReservedWords: array [TSQLReservedWords] of string = (
316	>	'ADD',
317	>	'ADMIN',
318	>	'ALL',
319	>	'ALTER',
320	>	'AND',
321	>	'ANY',
322	>	'AS',
323	>	'AT',
324	>	'AVG',
325	>	'BEGIN',
326	>	'BETWEEN',
327	>	'BIGINT',
328	>	'BIT_LENGTH',
329	>	'BLOB',
330	>	'BOOLEAN',
331	>	'BOTH',
332	>	'BY',
333	>	'CASE',
334	>	'CAST',
335	>	'CHAR',
336	>	'CHAR_LENGTH',
337	>	'CHARACTER',
338	>	'CHARACTER_LENGTH',
339	>	'CHECK',
340	>	'CLOSE',
341	>	'COLLATE',
342	>	'COLUMN',
343	>	'COMMIT',
344	>	'CONNECT',
345	>	'CONSTRAINT',
346	>	'CORR',
347	>	'COUNT',
348	>	'COVAR_POP',
349	>	'COVAR_SAMP',
350	>	'CREATE',
351	>	'CROSS',
352	>	'CURRENT',
353	>	'CURRENT_CONNECTION',
354	>	'CURRENT_DATE',
355	>	'CURRENT_ROLE',
356	>	'CURRENT_TIME',
357	>	'CURRENT_TIMESTAMP',
358	>	'CURRENT_TRANSACTION',
359	>	'CURRENT_USER',
360	>	'CURSOR',
361	>	'DATE',
362	>	'DAY',
363	>	'DEC',
364	>	'DECIMAL',
365	>	'DECLARE',
366	>	'DEFAULT',
367	>	'DELETE',
368	>	'DELETING',
369	>	'DETERMINISTIC',
370	>	'DISCONNECT',
371	>	'DISTINCT',
372	>	'DOUBLE',
373	>	'DROP',
374	>	'ELSE',
375	>	'END',
376	>	'ESCAPE',
377	>	'EXECUTE',
378	>	'EXISTS',
379	>	'EXTERNAL',
380	>	'EXTRACT',
381	>	'FALSE',
382	>	'FETCH',
383	>	'FILTER',
384	>	'FLOAT',
385	>	'FOR',
386	>	'FOREIGN',
387	>	'FROM',
388	>	'FULL',
389	>	'FUNCTION',
390	>	'GDSCODE',
391	>	'GLOBAL',
392	>	'GRANT',
393	>	'GROUP',
394	>	'HAVING',
395	>	'HOUR',
396	>	'IN',
397	>	'INDEX',
398	>	'INNER',
399	>	'INSENSITIVE',
400	>	'INSERT',
401	>	'INSERTING',
402	>	'INT',
403	>	'INTEGER',
404	>	'INTO',
405	>	'IS',
406	>	'JOIN',
407	>	'KEY',
408	>	'LEADING',
409	>	'LEFT',
410	>	'LIKE',
411	>	'LONG',
412	>	'LOWER',
413	>	'MAX',
414	>	'MAXIMUM_SEGMENT',
415	>	'MERGE',
416	>	'MIN',
417	>	'MINUTE',
418	>	'MONTH',
419	>	'NATIONAL',
420	>	'NATURAL',
421	>	'NCHAR',
422	>	'NO',
423	>	'NOT',
424	>	'NULL',
425	>	'NUMERIC',
426	>	'OCTET_LENGTH',
427	>	'OF',
428	>	'OFFSET',
429	>	'ON',
430	>	'ONLY',
431	>	'OPEN',
432	>	'OR',
433	>	'ORDER',
434	>	'OUTER',
435	>	'OVER',
436	>	'PARAMETER',
437	>	'PLAN',
438	>	'POSITION',
439	>	'POST_EVENT',
440	>	'PRECISION',
441	>	'PRIMARY',
442	>	'PROCEDURE',
443	>	'RDB$DB_KEY',
444	>	'RDB$RECORD_VERSION',
445	>	'REAL',
446	>	'RECORD_VERSION',
447	>	'RECREATE',
448	>	'RECURSIVE',
449	>	'REFERENCES',
450	>	'REGR_AVGX',
451	>	'REGR_AVGY',
452	>	'REGR_COUNT',
453	>	'REGR_INTERCEPT',
454	>	'REGR_R2',
455	>	'REGR_SLOPE',
456	>	'REGR_SXX',
457	>	'REGR_SXY',
458	>	'REGR_SYY',
459	>	'RELEASE',
460	>	'RETURN',
461	>	'RETURNING_VALUES',
462	>	'RETURNS',
463	>	'REVOKE',
464	>	'RIGHT',
465	>	'ROLLBACK',
466	>	'ROW',
467	>	'ROWS',
468	>	'ROW_COUNT',
469	>	'SAVEPOINT',
470	>	'SCROLL',
471	>	'SECOND',
472	>	'SELECT',
473	>	'SENSITIVE',
474	>	'SET',
475	>	'SIMILAR',
476	>	'SMALLINT',
477	>	'SOME',
478	>	'SQLCODE',
479	>	'SQLSTATE',
480	>	'START',
481	>	'STDDEV_POP',
482	>	'STDDEV_SAMP',
483	>	'SUM',
484	>	'TABLE',
485	>	'THEN',
486	>	'TIME',
487	>	'TIMESTAMP',
488	>	'TO',
489	>	'TRAILING',
490	>	'TRIGGER',
491	>	'TRIM',
492	>	'TRUE',
493	>	'UNION',
494	>	'UNIQUE',
495	>	'UNKNOWN',
496	>	'UPDATE',
497	>	'UPDATING',
498	>	'UPPER',
499	>	'USER',
500	>	'USING',
501	>	'VALUE',
502	>	'VALUES',
503	>	'VAR_POP',
504	>	'VAR_SAMP',
505	>	'VARCHAR',
506	>	'VARIABLE',
507	>	'VARYING',
508	>	'VIEW',
509	>	'WHEN',
510	>	'WHERE',
511	>	'WHILE',
512	>	'WITH',
513	>	'YEAR'
514	>	);
515	>
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): String;
767	>	function RandomString(iLength: Integer): AnsiString;
768		function RandomInteger(iLow, iHigh: Integer): Integer;
769	<	function StripString(st: String; CharsToStrip: String): String;
770	<	function FormatIdentifier(Dialect: Integer; Value: String): String;
771	<	function FormatIdentifierValue(Dialect: Integer; Value: String): String;
772	<	function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
773	<	function ExtractIdentifier(Dialect: Integer; Value: String): String;
774	<	function QuoteIdentifier(Dialect: Integer; Value: String): String;
775	<	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
776	<	function Space2Underscore(s: string): string;
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 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 103 | Line 841 | begin
841		result := n2;
842		end;
843
844	<	function RandomString(iLength: Integer): String;
844	>	function RandomString(iLength: Integer): AnsiString;
845		begin
846		result := '';
847		while Length(result) < iLength do
#	Line 117 | Line 855 | begin
855		result := Trunc(Random(iHigh - iLow)) + iLow;
856		end;
857
858	<	function StripString(st: String; CharsToStrip: String): String;
858	>	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
859		var
860		i: Integer;
861		begin
#	Line 128 | Line 866 | begin
866		end;
867		end;
868
869	<	function FormatIdentifier(Dialect: Integer; Value: String): String;
132	<	begin
133	<	Value := Trim(Value);
134	<	if Dialect = 1 then
135	<	Value := AnsiUpperCase(Value)
136	<	else
137	<	if (Value <> '') and (Value[1] = '"') then
138	<	Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
139	<	else
140	<	Value := AnsiUpperCase(Value);
141	<	Result := Value;
142	<	end;
869	>	{Extracts SQL Identifier typically from a  Dialect 3 encoding}
870
871	<	function FormatIdentifierValue(Dialect: Integer; Value: String): String;
871	>	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
872		begin
873		Value := Trim(Value);
874		if Dialect = 1 then
#	Line 160 | Line 887 | begin
887		Result := Value;
888		end;
889
890	<	function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
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;
179	–	Result := Value;
1066		end;
1067
1068	<	function ExtractIdentifier(Dialect: Integer; Value: String): String;
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);
193	<	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;
198	–	Result := Value;
1156		end;
1157	<
1158	<	function IsReservedWord(w: string): 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: String): String;
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
214	<	Value := AnsiUpperCase(Trim(Value))
215	<	else
216	<	Value := '"' + Value + '"';
217	<	Result := Value;
1183	>	Result := false;
1184		end;
1185
1186	<	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
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	<	function Space2Underscore(s: string): string;
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 45 by tony, Tue Dec 6 10:33:46 2016 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