ViewVC Help

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

root/public/ibx/branches/journaling/fbintf/IBUtils.pas

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 119 by tony, Mon Jan 22 13:58:18 2018 UTC vs.
Revision 348 by tony, Wed Oct 6 09:38:14 2021 UTC

#	Line 34 | Line 34
34		unit IBUtils;
35		{$IFDEF MSWINDOWS}
36		{$DEFINE WINDOWS}
37	–	{$IF defined(CompilerVersion) and (CompilerVersion >= 28)}
38	–	{Delphi XE7 onwards}}
39	–	{$define HASREQEX}
40	–	{$IFEND}
37		{$ENDIF}
38
39		{$IFDEF FPC}
40		{$Mode Delphi}
41		{$codepage UTF8}
46	–	{$define HASREQEX}
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	>	type
53	>	TSQLTokens = (
54	>
55	>	{Reserved Words}
56	>
57	>	sqltAdd,
58	>	sqltAdmin,
59	>	sqltAll,
60	>	sqltAlter,
61	>	sqltAnd,
62	>	sqltAny,
63	>	sqltAs,
64	>	sqltAt,
65	>	sqltAvg,
66	>	sqltBegin,
67	>	sqltBetween,
68	>	sqltBigint,
69	>	sqltBit_Length,
70	>	sqltBlob,
71	>	sqltBoolean,
72	>	sqltBoth,
73	>	sqltBy,
74	>	sqltCase,
75	>	sqltCast,
76	>	sqltChar,
77	>	sqltChar_Length,
78	>	sqltCharacter,
79	>	sqltCharacter_Length,
80	>	sqltCheck,
81	>	sqltClose,
82	>	sqltCollate,
83	>	sqltColumn,
84	>	sqltCommit,
85	>	sqltConnect,
86	>	sqltConstraint,
87	>	sqltCorr,
88	>	sqltCount,
89	>	sqltCovar_Pop,
90	>	sqltCovar_Samp,
91	>	sqltCreate,
92	>	sqltCross,
93	>	sqltCurrent,
94	>	sqltCurrent_Connection,
95	>	sqltCurrent_Date,
96	>	sqltCurrent_Role,
97	>	sqltCurrent_Time,
98	>	sqltCurrent_Timestamp,
99	>	sqltCurrent_Transaction,
100	>	sqltCurrent_User,
101	>	sqltCursor,
102	>	sqltDate,
103	>	sqltDay,
104	>	sqltDec,
105	>	sqltDecimal,
106	>	sqltDeclare,
107	>	sqltDefault,
108	>	sqltDelete,
109	>	sqltDeleting,
110	>	sqltDeterministic,
111	>	sqltDisconnect,
112	>	sqltDistinct,
113	>	sqltDouble,
114	>	sqltDrop,
115	>	sqltElse,
116	>	sqltEnd,
117	>	sqltEscape,
118	>	sqltExecute,
119	>	sqltExists,
120	>	sqltExternal,
121	>	sqltExtract,
122	>	sqltFalse,
123	>	sqltFetch,
124	>	sqltFilter,
125	>	sqltFloat,
126	>	sqltFor,
127	>	sqltForeign,
128	>	sqltFrom,
129	>	sqltFull,
130	>	sqltFunction,
131	>	sqltGdscode,
132	>	sqltGlobal,
133	>	sqltGrant,
134	>	sqltGroup,
135	>	sqltHaving,
136	>	sqltHour,
137	>	sqltIn,
138	>	sqltIndex,
139	>	sqltInner,
140	>	sqltInsensitive,
141	>	sqltInsert,
142	>	sqltInserting,
143	>	sqltInt,
144	>	sqltInteger,
145	>	sqltInto,
146	>	sqltIs,
147	>	sqltJoin,
148	>	sqltKey,
149	>	sqltLeading,
150	>	sqltLeft,
151	>	sqltLike,
152	>	sqltLong,
153	>	sqltLower,
154	>	sqltMax,
155	>	sqltMaximum_Segment,
156	>	sqltMerge,
157	>	sqltMin,
158	>	sqltMinute,
159	>	sqltMonth,
160	>	sqltNational,
161	>	sqltNatural,
162	>	sqltNchar,
163	>	sqltNo,
164	>	sqltNot,
165	>	sqltNull,
166	>	sqltNumeric,
167	>	sqltOctet_Length,
168	>	sqltOf,
169	>	sqltOffset,
170	>	sqltOn,
171	>	sqltOnly,
172	>	sqltOpen,
173	>	sqltOr,
174	>	sqltOrder,
175	>	sqltOuter,
176	>	sqltOver,
177	>	sqltParameter,
178	>	sqltPlan,
179	>	sqltPosition,
180	>	sqltPost_Event,
181	>	sqltPrecision,
182	>	sqltPrimary,
183	>	sqltProcedure,
184	>	sqltRdbDb_Key,
185	>	sqltRdbRecord_Version,
186	>	sqltReal,
187	>	sqltRecord_Version,
188	>	sqltRecreate,
189	>	sqltRecursive,
190	>	sqltReferences,
191	>	sqltRegr_Avgx,
192	>	sqltRegr_Avgy,
193	>	sqltRegr_Count,
194	>	sqltRegr_Intercept,
195	>	sqltRegr_R2,
196	>	sqltRegr_Slope,
197	>	sqltRegr_Sxx,
198	>	sqltRegr_Sxy,
199	>	sqltRegr_Syy,
200	>	sqltRelease,
201	>	sqltReturn,
202	>	sqltReturning_Values,
203	>	sqltReturns,
204	>	sqltRevoke,
205	>	sqltRight,
206	>	sqltRollback,
207	>	sqltRow,
208	>	sqltRows,
209	>	sqltRow_Count,
210	>	sqltSavepoint,
211	>	sqltScroll,
212	>	sqltSecond,
213	>	sqltSelect,
214	>	sqltSensitive,
215	>	sqltSet,
216	>	sqltSimilar,
217	>	sqltSmallint,
218	>	sqltSome,
219	>	sqltSqlcode,
220	>	sqltSqlstate,
221	>	sqltStart,
222	>	sqltStddev_Pop,
223	>	sqltStddev_Samp,
224	>	sqltSum,
225	>	sqltTable,
226	>	sqltThen,
227	>	sqltTime,
228	>	sqltTimestamp,
229	>	sqltTo,
230	>	sqltTrailing,
231	>	sqltTrigger,
232	>	sqltTrim,
233	>	sqltTrue,
234	>	sqltUnion,
235	>	sqltUnique,
236	>	sqltUnknown,
237	>	sqltUpdate,
238	>	sqltUpdating,
239	>	sqltUpper,
240	>	sqltUser,
241	>	sqltUsing,
242	>	sqltValue,
243	>	sqltValues,
244	>	sqltVar_Pop,
245	>	sqltVar_Samp,
246	>	sqltVarchar,
247	>	sqltVariable,
248	>	sqltVarying,
249	>	sqltView,
250	>	sqltWhen,
251	>	sqltWhere,
252	>	sqltWhile,
253	>	sqltWith,
254	>	sqltYear,
255	>
256	>	{symbols}
257	>
258	>	sqltSpace,
259	>	sqltSemiColon,
260	>	sqltPlaceholder,
261	>	sqltSingleQuotes,
262	>	sqltDoubleQuotes,
263	>	sqltBackslash,
264	>	sqltComma,
265	>	sqltPeriod,
266	>	sqltEquals,
267	>	sqltOtherCharacter,
268	>	sqltIdentifier,
269	>	sqltIdentifierInDoubleQuotes,
270	>	sqltNumberString,
271	>	sqltString,
272	>	sqltParam,
273	>	sqltQuotedParam,
274	>	sqltColon,
275	>	sqltComment,
276	>	sqltCommentLine,
277	>	sqltQuotedString,
278	>	sqltAsterisk,
279	>	sqltForwardSlash,
280	>	sqltOpenSquareBracket,
281	>	sqltCloseSquareBracket,
282	>	sqltOpenBracket,
283	>	sqltCloseBracket,
284	>	sqltPipe,
285	>	sqltMinus,
286	>	sqltConcatSymbol,
287	>	sqltLT,
288	>	sqltGT,
289	>	sqltCR,
290	>	sqltEOL,
291	>	sqltEOF,
292	>	sqltInit
293	>	);
294	>
295	>	TSQLReservedWords = sqltAdd..sqltYear;
296
297		const
298		CRLF = #13 + #10;
#	Line 58 | Line 301 | const
301		TAB  = #9;
302		NULL_TERMINATOR = #0;
303
304	<	sqlReservedWords: array [0..197] of string = (
304	>	{$IFNDEF FPC}
305	>	LineEnding = CRLF;
306	>	{$ENDIF}
307	>
308	>	{SQL Reserved words in alphabetical order}
309	>
310	>	sqlReservedWords: array [TSQLReservedWords] of string = (
311		'ADD',
312		'ADMIN',
313		'ALL',
#	Line 150 | Line 399 | const
399		'INTO',
400		'IS',
401		'JOIN',
402	+	'KEY',
403		'LEADING',
404		'LEFT',
405		'LIKE',
#	Line 209 | Line 459 | const
459		'RIGHT',
460		'ROLLBACK',
461		'ROW',
212	–	'ROW_COUNT',
462		'ROWS',
463	+	'ROW_COUNT',
464		'SAVEPOINT',
465		'SCROLL',
466		'SECOND',
#	Line 222 | Line 472 | const
472		'SOME',
473		'SQLCODE',
474		'SQLSTATE',
225	–	'SQLSTATE',
475		'START',
476		'STDDEV_POP',
477		'STDDEV_SAMP',
#	Line 259 | Line 508 | const
508		'YEAR'
509		);
510
511	+	type
512	+	{The TSQLTokeniser class provides a common means to parse an SQL statement, or
513	+	even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
514	+	with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
515	+	is instantiated with a stream from which the SQL statements are read.
516	+
517	+	Successive calls to GetNextToken then return each SQL token. The TokenText contains
518	+	either the single character, the identifier or reserved word, the string or comment.}
519	+
520	+	{ TSQLTokeniser }
521	+
522	+	TSQLTokeniser = class
523	+	private
524	+	const
525	+	TokenQueueMaxSize = 64;
526	+	type
527	+	TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
528	+	stInIdentifier, stInNumeric);
529	+
530	+	TTokenQueueItem = record
531	+	token: TSQLTokens;
532	+	text: AnsiString;
533	+	end;
534	+	TTokenQueueState = (tsHold, tsRelease);
535	+
536	+	private
537	+	FLastChar: AnsiChar;
538	+	FState: TLexState;
539	+	FSkipNext: boolean;
540	+	function GetNext: TSQLTokens;
541	+
542	+	{The token Queue is available for use by descendents so that they can
543	+	hold back tokens in order to lookahead by token rather than just a single
544	+	character}
545	+
546	+	private
547	+	FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
548	+	FQueueState: TTokenQueueState;
549	+	FQFirst: integer;  {first and last pointers first=last => queue empty}
550	+	FQLast: integer;
551	+	FEOF: boolean;
552	+	procedure PopQueue(var token: TSQLTokens);
553	+	protected
554	+	FString: AnsiString;
555	+	FNextToken: TSQLTokens;
556	+	procedure Assign(source: TSQLTokeniser); virtual;
557	+	function GetChar: AnsiChar; virtual; abstract;
558	+	function TokenFound(var token: TSQLTokens): boolean; virtual;
559	+	function InternalGetNextToken: TSQLTokens; virtual;
560	+	procedure Reset; virtual;
561	+
562	+	{Token stack}
563	+	procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
564	+	procedure QueueToken(token: TSQLTokens); overload;
565	+	procedure ResetQueue; overload;
566	+	procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
567	+	procedure ResetQueue(token: TSQLTokens); overload;
568	+	procedure ReleaseQueue(var token: TSQLTokens); overload;
569	+	procedure ReleaseQueue; overload;
570	+	function GetQueuedText: AnsiString;
571	+	procedure SetTokenText(text: AnsiString);
572	+
573	+	public
574	+	const
575	+	DefaultTerminator = ';';
576	+	public
577	+	constructor Create;
578	+	destructor Destroy; override;
579	+	function GetNextToken: TSQLTokens;
580	+	property EOF: boolean read FEOF;
581	+	property TokenText: AnsiString read FString;
582	+	end;
583	+
584	+	{ TSQLwithNamedParamsTokeniser }
585	+
586	+	TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
587	+	private
588	+	type
589	+	TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
590	+	private
591	+	FState: TSQLState;
592	+	FNested: integer;
593	+	protected
594	+	procedure Assign(source: TSQLTokeniser); override;
595	+	procedure Reset; override;
596	+	function TokenFound(var token: TSQLTokens): boolean; override;
597	+	end;
598	+
599	+	{ TSQLParamProcessor }
600	+
601	+	TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
602	+	private
603	+	const
604	+	sIBXParam = 'IBXParam';  {do not localize}
605	+	private
606	+	FInString: AnsiString;
607	+	FIndex: integer;
608	+	function DoExecute(GenerateParamNames: boolean;
609	+	var slNames: TStrings): AnsiString;
610	+	protected
611	+	function GetChar: AnsiChar; override;
612	+	public
613	+	class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
614	+	var slNames: TStrings): AnsiString;
615	+	end;
616	+
617	+
618		function Max(n1, n2: Integer): Integer;
619		function Min(n1, n2: Integer): Integer;
620		function RandomString(iLength: Integer): AnsiString;
621		function RandomInteger(iLow, iHigh: Integer): Integer;
622		function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
623		function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
625	+	function IsReservedWord(w: AnsiString): boolean;
626		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
627		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
628		function Space2Underscore(s: AnsiString): AnsiString;
629		function SQLSafeString(const s: AnsiString): AnsiString;
630		function IsSQLIdentifier(Value: AnsiString): boolean;
631		function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
632	+	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
633	+	PortNo: AnsiString = ''): AnsiString;
634	+	function ParseConnectString(ConnectString: AnsiString;
635	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
636	+	var PortNo: AnsiString): boolean;
637	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
638	+
639	+	{$IF declared(TFormatSettings)}
640	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
641	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
642	+	{$IFEND}
643	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
644	+	var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
645	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
646	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
647	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
648	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
649	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
650	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
651
652		implementation
653
654	<	{$IFDEF HASREQEX}
655	<	uses RegExpr;
656	<	{$ENDIF}
654	>	uses FBMessages
655	>
656	>	{$IFDEF FPC}
657	>	,RegExpr
658	>	{$ELSE}
659	>	{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
660	>	, RegularExpressions
661	>	{$IFEND}
662	>	{$ENDIF};
663	>
664
665		function Max(n1, n2: Integer): Integer;
666		begin
#	Line 340 | Line 724 | begin
724		Result := Value;
725		end;
726
727	+	{Returns true if "w" is a Firebird SQL reserved word, and the
728	+	corresponding TSQLTokens value.}
729	+
730	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
731	+	var i: TSQLTokens;
732	+	begin
733	+	Result := true;
734	+	w := AnsiUpperCase(Trim(w));
735	+	for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
736	+	begin
737	+	if w = sqlReservedWords[i] then
738	+	begin
739	+	token := i;
740	+	Exit;
741	+	end;
742	+	if w <  sqlReservedWords[i] then
743	+	break;
744	+	end;
745	+	Result := false;
746	+	end;
747	+
748		{Returns true if "w" is a Firebird SQL reserved word}
749
750		function IsReservedWord(w: AnsiString): boolean;
751	<	var i: integer;
751	>	var token: TSQLTokens;
752		begin
753	<	Result := true;
349	<	for i := 0 to Length(sqlReservedWords) - 1 do
350	<	if w = sqlReservedWords[i] then
351	<	Exit;
352	<	Result := false;
753	>	Result := FindReservedWord(w,token);
754		end;
755
756		{Format an SQL Identifier according to SQL Dialect}
757
758		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
759		begin
760	+	Value := TrimRight(Value);
761		if Dialect = 1 then
762	<	Value := AnsiUpperCase(Trim(Value))
762	>	Value := AnsiUpperCase(Value)
763		else
764		Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
765		Result := Value;
#	Line 377 | Line 779 | begin
779		Result := true;
780		end;
781
782	+	function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
783	+	begin
784	+	scheme := AnsiUpperCase(scheme);
785	+	if scheme = 'INET' then
786	+	Result := inet
787	+	else
788	+	if scheme = 'INET4' then
789	+	Result := inet4
790	+	else
791	+	if scheme = 'INET6' then
792	+	Result := inet6
793	+	else
794	+	if scheme = 'XNET' then
795	+	Result := xnet
796	+	else
797	+	if scheme = 'WNET' then
798	+	Result := wnet
799	+	end;
800	+
801		{Extracts the Database Connect string from a Create Database Statement}
802
803	<	{$IFDEF HASREQEX}
803	>	{$IF declared(TRegexpr)}
804		function ExtractConnectString(const CreateSQL: AnsiString;
805		var ConnectString: AnsiString): boolean;
806		var RegexObj: TRegExpr;
#	Line 392 | Line 813 | begin
813		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
814		Result := RegexObj.Exec(CreateSQL);
815		if Result then
816	<	ConnectString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
816	>	ConnectString := RegexObj.Match[2];
817		finally
818		RegexObj.Free;
819		end;
820		end;
821	+
822	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
823	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
824	+	): boolean;
825	+
826	+	var RegexObj: TRegExpr;
827	+	begin
828	+	ServerName := '';
829	+	DatabaseName := ConnectString;
830	+	PortNo := '';
831	+	Protocol := unknownProtocol;
832	+	RegexObj := TRegExpr.Create;
833	+	try
834	+	{extact database file spec}
835	+	RegexObj.ModifierG := false; {turn off greedy matches}
836	+	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
837	+	Result := RegexObj.Exec(ConnectString);
838	+	if Result then
839	+	begin
840	+	{URL type connect string}
841	+	Protocol := SchemeToProtocol(RegexObj.Match[1]);
842	+	ServerName := RegexObj.Match[2];
843	+	if RegexObj.MatchLen[3] > 0 then
844	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
845	+	DatabaseName := RegexObj.Match[4];
846	+	if ServerName = '' then
847	+	DatabaseName := '/' + DatabaseName;
848	+	end
849	+	else
850	+	begin
851	+	{URL type connect string - local loop}
852	+	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
853	+	Result := RegexObj.Exec(ConnectString);
854	+	if Result then
855	+	begin
856	+	Protocol := SchemeToProtocol(RegexObj.Match[1]);
857	+	DatabaseName := RegexObj.Match[2];
858	+	end
859	+	else
860	+	begin
861	+	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
862	+	Result := RegexObj.Exec(ConnectString);
863	+	if Result then
864	+	Protocol := Local {Windows with leading drive ID}
865	+	else
866	+	begin
867	+	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
868	+	Result := RegexObj.Exec(ConnectString);
869	+	if Result then
870	+	begin
871	+	{Legacy TCP Format}
872	+	ServerName := RegexObj.Match[1];
873	+	if RegexObj.MatchLen[2] > 0 then
874	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
875	+	DatabaseName := RegexObj.Match[3];
876	+	Protocol := TCP;
877	+	end
878	+	else
879	+	begin
880	+	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
881	+	Result := RegexObj.Exec(ConnectString);
882	+	if Result then
883	+	begin
884	+	{Netbui}
885	+	ServerName := RegexObj.Match[1];
886	+	if RegexObj.MatchLen[2] > 0 then
887	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
888	+	DatabaseName := RegexObj.Match[3];
889	+	Protocol := NamedPipe
890	+	end
891	+	else
892	+	begin
893	+	Result := true;
894	+	Protocol := Local; {Assume local}
895	+	end;
896	+	end;
897	+	end;
898	+	end;
899	+	end;
900	+	finally
901	+	RegexObj.Free;
902	+	end;
903	+	end;
904	+
905		{$ELSE}
906	<	{cruder version of above for old versions of Delphi}
906	>	{$IF declared(TRegex)}
907	>	function ExtractConnectString(const CreateSQL: AnsiString;
908	>	var ConnectString: AnsiString): boolean;
909	>	var Regex: TRegEx;
910	>	Match: TMatch;
911	>	begin
912	>	Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
913	>	{extact database file spec}
914	>	Match := Regex.Match(CreateSQL);
915	>	Result := Match.Success and (Match.Groups.Count = 3);
916	>	if Result then
917	>	ConnectString := Match.Groups[2].Value;
918	>	end;
919	>
920	>	function ParseConnectString(ConnectString: AnsiString; var ServerName,
921	>	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
922	>	): boolean;
923	>
924	>	var Regex: TRegEx;
925	>	Match: TMatch;
926	>	begin
927	>	ServerName := '';
928	>	DatabaseName := ConnectString;
929	>	PortNo := '';
930	>	Protocol := unknownProtocol;
931	>	{extact database file spec}
932	>	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
933	>	Result := Match.Success and (Match.Groups.Count = 5);
934	>	if Result then
935	>	begin
936	>	{URL type connect string}
937	>	Protocol := SchemeToProtocol(Match.Groups[1].Value);
938	>	ServerName := Match.Groups[2].Value;
939	>	PortNo := Match.Groups[3].Value;
940	>	DatabaseName := Match.Groups[4].Value;
941	>	if ServerName = '' then
942	>	DatabaseName := '/' + DatabaseName;
943	>	end
944	>	else
945	>	begin
946	>	{URL type connect string - local loop}
947	>	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
948	>	Result := Match.Success and (Match.Groups.Count = 3);
949	>	if Result then
950	>	begin
951	>	Protocol := SchemeToProtocol(Match.Groups[1].Value);
952	>	DatabaseName := Match.Groups[2].Value;
953	>	end
954	>	else
955	>	begin
956	>	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
957	>	Result := Match.Success;
958	>	if Result then
959	>	Protocol := Local {Windows with leading drive ID}
960	>	else
961	>	begin
962	>	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
963	>	Result := Match.Success and (Match.Groups.Count = 4);
964	>	if Result then
965	>	begin
966	>	{Legacy TCP Format}
967	>	ServerName := Match.Groups[1].Value;
968	>	PortNo := Match.Groups[2].Value;
969	>	DatabaseName := Match.Groups[3].Value;
970	>	Protocol := TCP;
971	>	end
972	>	else
973	>	begin
974	>	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
975	>	Result := Match.Success and (Match.Groups.Count = 4);
976	>	if Result then
977	>	begin
978	>	{Netbui}
979	>	ServerName := Match.Groups[1].Value;
980	>	PortNo := Match.Groups[2].Value;
981	>	DatabaseName := Match.Groups[3].Value;
982	>	Protocol := NamedPipe
983	>	end
984	>	else
985	>	begin
986	>	Result := true;
987	>	Protocol := Local; {Assume local}
988	>	end;
989	>	end;
990	>	end;
991	>	end;
992	>	end;
993	>	end;
994	>	{$ELSE}
995	>	{cruder version of above for Delphi < XE. Older versions lack regular expression
996	>	handling.}
997		function ExtractConnectString(const CreateSQL: AnsiString;
998		var ConnectString: AnsiString): boolean;
999		var i: integer;
#	Line 417 | Line 1012 | begin
1012		end;
1013		end;
1014		end;
1015	<	{$ENDIF}
1015	>
1016	>	function ParseConnectString(ConnectString: AnsiString;
1017	>	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1018	>	var PortNo: AnsiString): boolean;
1019	>	begin
1020	>	Result := false;
1021	>	end;
1022	>
1023	>	{$IFEND}
1024	>	{$IFEND}
1025	>
1026	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1027	>	var ServerName,
1028	>	DatabaseName: AnsiString;
1029	>	PortNo: AnsiString;
1030	>	begin
1031	>	if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1032	>	Result := unknownProtocol;
1033	>	end;
1034	>
1035	>	{Make a connect string in format appropriate protocol}
1036	>
1037	>	function MakeConnectString(ServerName, DatabaseName: AnsiString;
1038	>	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1039	>
1040	>	function FormatURL: AnsiString;
1041	>	begin
1042	>	if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1043	>	Result := DatabaseName
1044	>	else
1045	>	Result := ServerName + '/' + DatabaseName;
1046	>	end;
1047	>
1048	>	begin
1049	>	if ServerName = '' then ServerName := 'localhost';
1050	>	if PortNo <> '' then
1051	>	case Protocol of
1052	>	NamedPipe:
1053	>	ServerName := ServerName + '@' + PortNo;
1054	>	Local,
1055	>	SPX,
1056	>	xnet: {do nothing};
1057	>	TCP:
1058	>	ServerName := ServerName + '/' + PortNo;
1059	>	else
1060	>	ServerName := ServerName + ':' + PortNo;
1061	>	end;
1062	>
1063	>	case Protocol of
1064	>	TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
1065	>	SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
1066	>	NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1067	>	Local:      Result := DatabaseName; {do not localize}
1068	>	inet:       Result := 'inet://' + FormatURL; {do not localize}
1069	>	inet4:       Result := 'inet4://' + FormatURL; {do not localize}
1070	>	inet6:       Result := 'inet6://' + FormatURL; {do not localize}
1071	>	wnet:       Result := 'wnet://' + FormatURL; {do not localize}
1072	>	xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
1073	>	end;
1074	>	end;
1075
1076		{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1077
1078		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1079		begin
1080	+	Value := TrimRight(Value);
1081		if (Dialect = 3) and
1082		(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1083		Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
#	Line 449 | Line 1104 | begin
1104		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1105		end;
1106
1107	+	{ TSQLParamProcessor }
1108	+
1109	+	function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1110	+	var slNames: TStrings): AnsiString;
1111	+	var token: TSQLTokens;
1112	+	iParamSuffix: Integer;
1113	+	begin
1114	+	Result := '';
1115	+	iParamSuffix := 0;
1116	+
1117	+	while not EOF do
1118	+	begin
1119	+	token := GetNextToken;
1120	+	case token of
1121	+	sqltParam,
1122	+	sqltQuotedParam:
1123	+	begin
1124	+	Result := Result + '?';
1125	+	slNames.Add(TokenText);
1126	+	end;
1127	+
1128	+	sqltPlaceHolder:
1129	+	if GenerateParamNames then
1130	+	begin
1131	+	Inc(iParamSuffix);
1132	+	slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1133	+	//add pointer to self to mark entry
1134	+	Result := Result + '?';
1135	+	end
1136	+	else
1137	+	IBError(ibxeSQLParseError, [SParamNameExpected]);
1138	+
1139	+	sqltQuotedString:
1140	+	Result := Result + '''' + SQLSafeString(TokenText) + '''';
1141	+
1142	+	sqltIdentifierInDoubleQuotes:
1143	+	Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1144	+
1145	+	sqltComment:
1146	+	Result := Result + '/*' + TokenText + '*/';
1147	+
1148	+	sqltCommentLine:
1149	+	Result := Result + '--' + TokenText + LineEnding;
1150	+
1151	+	sqltEOL:
1152	+	Result := Result + LineEnding;
1153	+
1154	+	else
1155	+	Result := Result + TokenText;
1156	+	end;
1157	+	end;
1158	+	end;
1159	+
1160	+	function TSQLParamProcessor.GetChar: AnsiChar;
1161	+	begin
1162	+	if FIndex <= Length(FInString) then
1163	+	begin
1164	+	Result := FInString[FIndex];
1165	+	Inc(FIndex);
1166	+	end
1167	+	else
1168	+	Result := #0;
1169	+	end;
1170	+
1171	+	class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1172	+	GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1173	+	begin
1174	+	with self.Create do
1175	+	try
1176	+	FInString := sSQL;
1177	+	FIndex := 1;
1178	+	Result := DoExecute(GenerateParamNames,slNames);
1179	+	finally
1180	+	Free;
1181	+	end;
1182	+	end;
1183	+
1184	+	{ TSQLwithNamedParamsTokeniser }
1185	+
1186	+	procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1187	+	begin
1188	+	inherited Assign(source);
1189	+	if source is TSQLwithNamedParamsTokeniser then
1190	+	begin
1191	+	FState := TSQLwithNamedParamsTokeniser(source).FState;
1192	+	FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1193	+	end;
1194	+	end;
1195	+
1196	+	procedure TSQLwithNamedParamsTokeniser.Reset;
1197	+	begin
1198	+	inherited Reset;
1199	+	FState := stInit;
1200	+	FNested := 0;
1201	+	end;
1202	+
1203	+	function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1204	+	): boolean;
1205	+	begin
1206	+	Result := inherited TokenFound(token);
1207	+	if not Result then Exit;
1208	+
1209	+	case FState of
1210	+	stInit:
1211	+	begin
1212	+	case token of
1213	+	sqltColon:
1214	+	begin
1215	+	FState := stInParam;
1216	+	ResetQueue(token);
1217	+	end;
1218	+
1219	+	sqltBegin:
1220	+	begin
1221	+	FState := stInBlock;
1222	+	FNested := 1;
1223	+	end;
1224	+
1225	+	sqltOpenSquareBracket:
1226	+	FState := stInArrayDim;
1227	+
1228	+	end;
1229	+	end;
1230	+
1231	+	stInParam:
1232	+	begin
1233	+	case token of
1234	+	sqltIdentifier:
1235	+	token := sqltParam;
1236	+
1237	+	sqltIdentifierInDoubleQuotes:
1238	+	token := sqltQuotedParam;
1239	+
1240	+	else
1241	+	begin
1242	+	QueueToken(token);
1243	+	ReleaseQueue(token);
1244	+	end;
1245	+	end;
1246	+	FState := stInit;
1247	+	end;
1248	+
1249	+	stInBlock:
1250	+	begin
1251	+	case token of
1252	+	sqltBegin,
1253	+	sqltCase:
1254	+	Inc(FNested);
1255	+
1256	+	sqltEnd:
1257	+	begin
1258	+	Dec(FNested);
1259	+	if FNested = 0 then
1260	+	FState := stInit;
1261	+	end;
1262	+	end;
1263	+	end;
1264	+
1265	+	stInArrayDim:
1266	+	begin
1267	+	if token = sqltCloseSquareBracket then
1268	+	FState := stInit;
1269	+	end;
1270	+	end;
1271	+
1272	+	Result := (FState <> stInParam);
1273	+	end;
1274	+
1275	+	{ TSQLTokeniser }
1276	+
1277	+	function TSQLTokeniser.GetNext: TSQLTokens;
1278	+	var C: AnsiChar;
1279	+	begin
1280	+	if EOF then
1281	+	Result := sqltEOF
1282	+	else
1283	+	begin
1284	+	C := GetChar;
1285	+	case C of
1286	+	#0:
1287	+	Result := sqltEOF;
1288	+	' ',TAB:
1289	+	Result := sqltSpace;
1290	+	'0'..'9':
1291	+	Result := sqltNumberString;
1292	+	';':
1293	+	Result := sqltSemiColon;
1294	+	'?':
1295	+	Result := sqltPlaceholder;
1296	+	'|':
1297	+	Result := sqltPipe;
1298	+	'"':
1299	+	Result := sqltDoubleQuotes;
1300	+	'''':
1301	+	Result := sqltSingleQuotes;
1302	+	'/':
1303	+	Result := sqltForwardSlash;
1304	+	'\':
1305	+	Result := sqltBackslash;
1306	+	'*':
1307	+	Result := sqltAsterisk;
1308	+	'(':
1309	+	Result := sqltOpenBracket;
1310	+	')':
1311	+	Result := sqltCloseBracket;
1312	+	':':
1313	+	Result := sqltColon;
1314	+	',':
1315	+	Result := sqltComma;
1316	+	'.':
1317	+	Result := sqltPeriod;
1318	+	'=':
1319	+	Result := sqltEquals;
1320	+	'[':
1321	+	Result := sqltOpenSquareBracket;
1322	+	']':
1323	+	Result := sqltCloseSquareBracket;
1324	+	'-':
1325	+	Result := sqltMinus;
1326	+	'<':
1327	+	Result := sqltLT;
1328	+	'>':
1329	+	Result := sqltGT;
1330	+	CR:
1331	+	Result := sqltCR;
1332	+	LF:
1333	+	Result := sqltEOL;
1334	+	else
1335	+	if C in ValidSQLIdentifierChars then
1336	+	Result := sqltIdentifier
1337	+	else
1338	+	Result := sqltOtherCharacter;
1339	+	end;
1340	+	FLastChar := C
1341	+	end;
1342	+	FNextToken := Result;
1343	+	end;
1344	+
1345	+	procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1346	+	begin
1347	+	if FQFirst = FQLast then
1348	+	IBError(ibxeTokenQueueUnderflow,[]);
1349	+	token := FTokenQueue[FQFirst].token;
1350	+	FString := FTokenQueue[FQFirst].text;
1351	+	Inc(FQFirst);
1352	+	if FQFirst = FQLast then
1353	+	FQueueState := tsHold;
1354	+	end;
1355	+
1356	+	procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1357	+	begin
1358	+	FString := source.FString;
1359	+	FNextToken := source.FNextToken;
1360	+	FTokenQueue := source.FTokenQueue;
1361	+	FQueueState := source.FQueueState;
1362	+	FQFirst := source.FQFirst;
1363	+	FQLast := source.FQLast;
1364	+	end;
1365	+
1366	+	function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1367	+	begin
1368	+	Result := (FState = stDefault);
1369	+	if Result and (token = sqltIdentifier)  then
1370	+	FindReservedWord(FString,token);
1371	+	end;
1372	+
1373	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1374	+	begin
1375	+	if FQLast > TokenQueueMaxSize then
1376	+	IBError(ibxeTokenQueueOverflow,[]);
1377	+	FTokenQueue[FQLast].token := token;
1378	+	FTokenQueue[FQLast].text := text;
1379	+	Inc(FQLast);
1380	+	end;
1381	+
1382	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1383	+	begin
1384	+	QueueToken(token,TokenText);
1385	+	end;
1386	+
1387	+	procedure TSQLTokeniser.ResetQueue;
1388	+	begin
1389	+	FQFirst := 0;
1390	+	FQLast := 0;
1391	+	FQueueState := tsHold;
1392	+	end;
1393	+
1394	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1395	+	begin
1396	+	ResetQueue;
1397	+	QueueToken(token,text);
1398	+	end;
1399	+
1400	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1401	+	begin
1402	+	ResetQueue;
1403	+	QueueToken(token);
1404	+	end;
1405	+
1406	+	procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1407	+	begin
1408	+	FQueueState := tsRelease;
1409	+	PopQueue(token);
1410	+	end;
1411	+
1412	+	procedure TSQLTokeniser.ReleaseQueue;
1413	+	begin
1414	+	FQueueState := tsRelease;
1415	+	end;
1416	+
1417	+	function TSQLTokeniser.GetQueuedText: AnsiString;
1418	+	var i: integer;
1419	+	begin
1420	+	Result := '';
1421	+	for i := FQFirst to FQLast do
1422	+	Result := Result + FTokenQueue[i].text;
1423	+	end;
1424	+
1425	+	procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1426	+	begin
1427	+	FString := text;
1428	+	end;
1429	+
1430	+	constructor TSQLTokeniser.Create;
1431	+	begin
1432	+	inherited Create;
1433	+	Reset;
1434	+	end;
1435	+
1436	+	destructor TSQLTokeniser.Destroy;
1437	+	begin
1438	+	Reset;
1439	+	inherited Destroy;
1440	+	end;
1441	+
1442	+	procedure TSQLTokeniser.Reset;
1443	+	begin
1444	+	FNextToken := sqltInit;
1445	+	FState := stDefault;
1446	+	FString := '';
1447	+	FEOF := false;
1448	+	ResetQueue;
1449	+	end;
1450	+
1451	+	function TSQLTokeniser.GetNextToken: TSQLTokens;
1452	+	begin
1453	+	if FQueueState = tsRelease then
1454	+	repeat
1455	+	PopQueue(Result);
1456	+	FEOF := Result = sqltEOF;
1457	+	if TokenFound(Result) then
1458	+	Exit;
1459	+	until FQueueState <> tsRelease;
1460	+
1461	+	Result := InternalGetNextToken;
1462	+	end;
1463	+
1464	+	{a simple lookahead one algorithm to extra the next symbol}
1465	+
1466	+	function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1467	+	var C: AnsiChar;
1468	+	begin
1469	+	Result := sqltEOF;
1470	+
1471	+	if FNextToken = sqltInit then
1472	+	GetNext;
1473	+
1474	+	repeat
1475	+	Result := FNextToken;
1476	+	C := FLastChar;
1477	+	GetNext;
1478	+
1479	+	if FSkipNext then
1480	+	begin
1481	+	FSkipNext := false;
1482	+	continue;
1483	+	end;
1484	+
1485	+	case FState of
1486	+	stInComment:
1487	+	begin
1488	+	if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1489	+	begin
1490	+	FState := stDefault;
1491	+	Result := sqltComment;
1492	+	GetNext;
1493	+	end
1494	+	else
1495	+	FString := FString + C;
1496	+	end;
1497	+
1498	+	stInCommentLine:
1499	+	begin
1500	+	case Result of
1501	+	sqltEOL:
1502	+	begin
1503	+	FState := stDefault;
1504	+	Result := sqltCommentLine;
1505	+	end;
1506	+
1507	+	sqltCR: {ignore};
1508	+
1509	+	else
1510	+	FString := FString + C;
1511	+	end;
1512	+	end;
1513	+
1514	+	stSingleQuoted:
1515	+	begin
1516	+	if (Result = sqltSingleQuotes) then
1517	+	begin
1518	+	if (FNextToken = sqltSingleQuotes) then
1519	+	begin
1520	+	FSkipNext := true;
1521	+	FString := FString + C;
1522	+	end
1523	+	else
1524	+	begin
1525	+	Result := sqltQuotedString;
1526	+	FState := stDefault;
1527	+	end;
1528	+	end
1529	+	else
1530	+	FString := FString + C;
1531	+	end;
1532	+
1533	+	stDoubleQuoted:
1534	+	begin
1535	+	if (Result = sqltDoubleQuotes) then
1536	+	begin
1537	+	if (FNextToken = sqltDoubleQuotes) then
1538	+	begin
1539	+	FSkipNext := true;
1540	+	FString := FString + C;
1541	+	end
1542	+	else
1543	+	begin
1544	+	Result := sqltIdentifierInDoubleQuotes;
1545	+	FState := stDefault;
1546	+	end;
1547	+	end
1548	+	else
1549	+	FString := FString + C;
1550	+	end;
1551	+
1552	+	stInIdentifier:
1553	+	begin
1554	+	FString := FString + C;
1555	+	Result := sqltIdentifier;
1556	+	if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1557	+	FState := stDefault
1558	+	end;
1559	+
1560	+	stInNumeric:
1561	+	begin
1562	+	FString := FString + C;
1563	+	if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1564	+	begin
1565	+	{malformed decimal}
1566	+	FState := stInIdentifier;
1567	+	Result := sqltIdentifier
1568	+	end
1569	+	else
1570	+	begin
1571	+	if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1572	+	FState := stDefault;
1573	+	Result := sqltNumberString;
1574	+	end;
1575	+	end;
1576	+
1577	+	else {stDefault}
1578	+	begin
1579	+	FString := C;
1580	+	case Result of
1581	+
1582	+	sqltPipe:
1583	+	if FNextToken = sqltPipe then
1584	+	begin
1585	+	Result := sqltConcatSymbol;
1586	+	FString := C + FLastChar;
1587	+	GetNext;
1588	+	end;
1589	+
1590	+	sqltForwardSlash:
1591	+	begin
1592	+	if FNextToken = sqltAsterisk then
1593	+	begin
1594	+	FString := '';
1595	+	GetNext;
1596	+	FState := stInComment;
1597	+	end
1598	+	end;
1599	+
1600	+	sqltMinus:
1601	+	begin
1602	+	if FNextToken = sqltMinus then
1603	+	begin
1604	+	FString := '';
1605	+	GetNext;
1606	+	FState := stInCommentLine;
1607	+	end;
1608	+	end;
1609	+
1610	+	sqltSingleQuotes:
1611	+	begin
1612	+	FString := '';
1613	+	FState := stSingleQuoted;
1614	+	end;
1615	+
1616	+	sqltDoubleQuotes:
1617	+	begin
1618	+	FString := '';
1619	+	FState := stDoubleQuoted;
1620	+	end;
1621	+
1622	+	sqltIdentifier:
1623	+	if FNextToken in [sqltIdentifier,sqltNumberString] then
1624	+	FState := stInIdentifier;
1625	+
1626	+	sqltNumberString:
1627	+	if FNextToken in [sqltNumberString,sqltPeriod] then
1628	+	FState := stInNumeric;
1629	+	end;
1630	+	end;
1631	+	end;
1632	+
1633	+	//    writeln(FString);
1634	+	FEOF := Result = sqltEOF;
1635	+	until TokenFound(Result) or EOF;
1636	+	end;
1637	+
1638	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1639	+	var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1640	+	{$IF declared(TFormatSettings)}
1641	+	begin
1642	+	{$IF declared(DefaultFormatSettings)}
1643	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1644	+	{$ELSE}
1645	+	{$IF declared(FormatSettings)}
1646	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1647	+	{$IFEND} {$IFEND}
1648	+	end;
1649	+
1650	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1651	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1652	+	{$IFEND}
1653	+	const
1654	+	whitespacechars = [' ',#$09,#$0A,#$0D];
1655	+	var i,j,l: integer;
1656	+	aTime: TDateTime;
1657	+	DMs: longint;
1658	+	begin
1659	+	Result := false;
1660	+	aTimezone := '';
1661	+	if aDateTimeStr <> '' then
1662	+	{$if declared(TFormatSettings)}
1663	+	with aFormatSettings do
1664	+	{$IFEND}
1665	+	begin
1666	+	aDateTime := 0;
1667	+	{Parse to get time zone info}
1668	+	i := 1;
1669	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1670	+	if not TimeOnly then
1671	+	begin
1672	+	{decode date}
1673	+	j := i;
1674	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1675	+	if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1676	+	i := j; {otherwise start again i.e. assume time only}
1677	+	end;
1678	+
1679	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1680	+	{decode time}
1681	+	j := i;
1682	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1683	+	Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1684	+	if not Result then Exit;
1685	+	aDateTime := aDateTime + aTime;
1686	+	i := j;
1687	+
1688	+	{is there a factional second part}
1689	+	if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1690	+	begin
1691	+	inc(i);
1692	+	inc(j);
1693	+	while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1694	+	if j > i then
1695	+	begin
1696	+	l := j-i;
1697	+	if l > 4 then l := 4;
1698	+	Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1699	+	if not Result then Exit;
1700	+
1701	+	{adjust for number of significant digits}
1702	+	case l of
1703	+	3:   DMs := DMs * 10;
1704	+	2:   DMs := DMs * 100;
1705	+	1:   DMs := DMs * 1000;
1706	+	end;
1707	+	aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1708	+	end;
1709	+	end;
1710	+	i := j;
1711	+
1712	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1713	+	{decode time zone}
1714	+	if i < length(aDateTimeStr) then
1715	+	begin
1716	+	j := i;
1717	+	while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1718	+	aTimezone := system.copy(aDateTimeStr,i,j-i);
1719	+	end;
1720	+	Result := true;
1721	+	end
1722	+	end;
1723	+
1724	+	{The following is similar to FPC DecodeTime except that the Firebird standard
1725	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1726	+
1727	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1728	+	var DeciMillisecond: cardinal);
1729	+	var D : Double;
1730	+	l : cardinal;
1731	+	begin
1732	+	{conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1733	+	D := aTime * MSecsPerDay *10;
1734	+	if D < 0 then
1735	+	D := D - 0.5
1736	+	else
1737	+	D := D + 0.5;
1738	+	{rest hacked from FPC DecodeTIme}
1739	+	l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1740	+	Hour   := l div 36000000;
1741	+	l := l mod 36000000;
1742	+	Minute := l div 600000;
1743	+	l := l mod 600000;
1744	+	Second := l div 10000;
1745	+	DeciMillisecond := l mod 10000;
1746	+	end;
1747	+
1748	+	{The following is similar to FPC EncodeTime except that the Firebird standard
1749	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1750	+
1751	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1752	+	const DMSecsPerDay = MSecsPerDay*10;
1753	+	var DMs: cardinal;
1754	+	D: Double;
1755	+	begin
1756	+	if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1757	+	begin
1758	+	DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1759	+	D := DMs/DMSecsPerDay;
1760	+	Result:=TDateTime(d)
1761	+	end
1762	+	else
1763	+	IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1764	+	end;
1765	+
1766	+	{The following is similar to FPC FormatDateTime except that it additionally
1767	+	allows the timstamp to have a fractional seconds component with a resolution
1768	+	of four decimal places. This is appended to the result for FormatDateTime
1769	+	if the format string contains a "zzzz' string.}
1770	+
1771	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1772	+	var Hour, Minute, Second: word;
1773	+	DeciMillisecond: cardinal;
1774	+	begin
1775	+	if Pos('zzzz',fmt) > 0 then
1776	+	begin
1777	+	FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1778	+	fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1779	+	end;
1780	+	Result := FormatDateTime(fmt,aDateTime);
1781	+	end;
1782	+
1783	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1784	+	begin
1785	+	if EffectiveTimeOffsetMins > 0 then
1786	+	Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1787	+	else
1788	+	Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1789	+	end;
1790	+
1791	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1792	+	var i: integer;
1793	+	begin
1794	+	Result := false;
1795	+	TZOffset := Trim(TZOffset);
1796	+	for i := 1 to Length(TZOffset) do
1797	+	if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1798	+
1799	+	Result := true;
1800	+	i := Pos(':',TZOffset);
1801	+	if i > 0 then
1802	+	dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1803	+	else
1804	+	dstOffset := StrToInt(TZOffset) * 60;
1805	+	end;
1806	+
1807	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
1808	+	var i: Integer;
1809	+	start: integer;
1810	+	begin
1811	+	Result := '';
1812	+	start := 1;
1813	+	if (Length(Value) > 0) and (Value[1] = '-') then
1814	+	begin
1815	+	Result := '-';
1816	+	start := 2;
1817	+	end;
1818	+	for i := start to Length(Value) do
1819	+	if Value[i] <> '0' then
1820	+	begin
1821	+	Result := Result + system.copy(Value, i, MaxInt);
1822	+	Exit;
1823	+	end;
1824	+	end;
1825	+
1826		end.

Diff Legend

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