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 119 by tony, Mon Jan 22 13:58:18 2018 UTC vs.
Revision 356 by tony, Sun Oct 24 14:00:52 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	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
652	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
653	+
654
655		implementation
656
657	<	{$IFDEF HASREQEX}
658	<	uses RegExpr;
659	<	{$ENDIF}
657	>	uses FBMessages, Math
658	>
659	>	{$IFDEF FPC}
660	>	,RegExpr
661	>	{$ELSE}
662	>	{$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
663	>	, RegularExpressions
664	>	{$IFEND}
665	>	{$ENDIF};
666	>
667
668		function Max(n1, n2: Integer): Integer;
669		begin
#	Line 340 | Line 727 | begin
727		Result := Value;
728		end;
729
730	+	{Returns true if "w" is a Firebird SQL reserved word, and the
731	+	corresponding TSQLTokens value.}
732	+
733	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
734	+	var i: TSQLTokens;
735	+	begin
736	+	Result := true;
737	+	w := AnsiUpperCase(Trim(w));
738	+	for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
739	+	begin
740	+	if w = sqlReservedWords[i] then
741	+	begin
742	+	token := i;
743	+	Exit;
744	+	end;
745	+	if w <  sqlReservedWords[i] then
746	+	break;
747	+	end;
748	+	Result := false;
749	+	end;
750	+
751		{Returns true if "w" is a Firebird SQL reserved word}
752
753		function IsReservedWord(w: AnsiString): boolean;
754	<	var i: integer;
754	>	var token: TSQLTokens;
755		begin
756	<	Result := true;
349	<	for i := 0 to Length(sqlReservedWords) - 1 do
350	<	if w = sqlReservedWords[i] then
351	<	Exit;
352	<	Result := false;
756	>	Result := FindReservedWord(w,token);
757		end;
758
759		{Format an SQL Identifier according to SQL Dialect}
760
761		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
762		begin
763	+	Value := TrimRight(Value);
764		if Dialect = 1 then
765	<	Value := AnsiUpperCase(Trim(Value))
765	>	Value := AnsiUpperCase(Value)
766		else
767		Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
768		Result := Value;
#	Line 377 | Line 782 | begin
782		Result := true;
783		end;
784
785	+	function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
786	+	begin
787	+	scheme := AnsiUpperCase(scheme);
788	+	if scheme = 'INET' then
789	+	Result := inet
790	+	else
791	+	if scheme = 'INET4' then
792	+	Result := inet4
793	+	else
794	+	if scheme = 'INET6' then
795	+	Result := inet6
796	+	else
797	+	if scheme = 'XNET' then
798	+	Result := xnet
799	+	else
800	+	if scheme = 'WNET' then
801	+	Result := wnet
802	+	end;
803	+
804		{Extracts the Database Connect string from a Create Database Statement}
805
806	<	{$IFDEF HASREQEX}
806	>	{$IF declared(TRegexpr)}
807		function ExtractConnectString(const CreateSQL: AnsiString;
808		var ConnectString: AnsiString): boolean;
809		var RegexObj: TRegExpr;
#	Line 392 | Line 816 | begin
816		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
817		Result := RegexObj.Exec(CreateSQL);
818		if Result then
819	<	ConnectString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
819	>	ConnectString := RegexObj.Match[2];
820		finally
821		RegexObj.Free;
822		end;
823		end;
824	+
825	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
826	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
827	+	): boolean;
828	+
829	+	var RegexObj: TRegExpr;
830	+	begin
831	+	ServerName := '';
832	+	DatabaseName := ConnectString;
833	+	PortNo := '';
834	+	Protocol := unknownProtocol;
835	+	RegexObj := TRegExpr.Create;
836	+	try
837	+	{extact database file spec}
838	+	RegexObj.ModifierG := false; {turn off greedy matches}
839	+	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
840	+	Result := RegexObj.Exec(ConnectString);
841	+	if Result then
842	+	begin
843	+	{URL type connect string}
844	+	Protocol := SchemeToProtocol(RegexObj.Match[1]);
845	+	ServerName := RegexObj.Match[2];
846	+	if RegexObj.MatchLen[3] > 0 then
847	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
848	+	DatabaseName := RegexObj.Match[4];
849	+	if ServerName = '' then
850	+	DatabaseName := '/' + DatabaseName;
851	+	end
852	+	else
853	+	begin
854	+	{URL type connect string - local loop}
855	+	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
856	+	Result := RegexObj.Exec(ConnectString);
857	+	if Result then
858	+	begin
859	+	Protocol := SchemeToProtocol(RegexObj.Match[1]);
860	+	DatabaseName := RegexObj.Match[2];
861	+	end
862	+	else
863	+	begin
864	+	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
865	+	Result := RegexObj.Exec(ConnectString);
866	+	if Result then
867	+	Protocol := Local {Windows with leading drive ID}
868	+	else
869	+	begin
870	+	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
871	+	Result := RegexObj.Exec(ConnectString);
872	+	if Result then
873	+	begin
874	+	{Legacy TCP Format}
875	+	ServerName := RegexObj.Match[1];
876	+	if RegexObj.MatchLen[2] > 0 then
877	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
878	+	DatabaseName := RegexObj.Match[3];
879	+	Protocol := TCP;
880	+	end
881	+	else
882	+	begin
883	+	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
884	+	Result := RegexObj.Exec(ConnectString);
885	+	if Result then
886	+	begin
887	+	{Netbui}
888	+	ServerName := RegexObj.Match[1];
889	+	if RegexObj.MatchLen[2] > 0 then
890	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
891	+	DatabaseName := RegexObj.Match[3];
892	+	Protocol := NamedPipe
893	+	end
894	+	else
895	+	begin
896	+	Result := true;
897	+	Protocol := Local; {Assume local}
898	+	end;
899	+	end;
900	+	end;
901	+	end;
902	+	end;
903	+	finally
904	+	RegexObj.Free;
905	+	end;
906	+	end;
907	+
908	+	{$ELSE}
909	+	{$IF declared(TRegex)}
910	+	function ExtractConnectString(const CreateSQL: AnsiString;
911	+	var ConnectString: AnsiString): boolean;
912	+	var Regex: TRegEx;
913	+	Match: TMatch;
914	+	begin
915	+	Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
916	+	{extact database file spec}
917	+	Match := Regex.Match(CreateSQL);
918	+	Result := Match.Success and (Match.Groups.Count = 3);
919	+	if Result then
920	+	ConnectString := Match.Groups[2].Value;
921	+	end;
922	+
923	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
924	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
925	+	): boolean;
926	+
927	+	var Regex: TRegEx;
928	+	Match: TMatch;
929	+	begin
930	+	ServerName := '';
931	+	DatabaseName := ConnectString;
932	+	PortNo := '';
933	+	Protocol := unknownProtocol;
934	+	{extact database file spec}
935	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
936	+	Result := Match.Success and (Match.Groups.Count = 5);
937	+	if Result then
938	+	begin
939	+	{URL type connect string}
940	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
941	+	ServerName := Match.Groups[2].Value;
942	+	PortNo := Match.Groups[3].Value;
943	+	DatabaseName := Match.Groups[4].Value;
944	+	if ServerName = '' then
945	+	DatabaseName := '/' + DatabaseName;
946	+	end
947	+	else
948	+	begin
949	+	{URL type connect string - local loop}
950	+	Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
951	+	Result := Match.Success and (Match.Groups.Count = 3);
952	+	if Result then
953	+	begin
954	+	Protocol := SchemeToProtocol(Match.Groups[1].Value);
955	+	DatabaseName := Match.Groups[2].Value;
956	+	end
957	+	else
958	+	begin
959	+	Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
960	+	Result := Match.Success;
961	+	if Result then
962	+	Protocol := Local {Windows with leading drive ID}
963	+	else
964	+	begin
965	+	Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
966	+	Result := Match.Success and (Match.Groups.Count = 4);
967	+	if Result then
968	+	begin
969	+	{Legacy TCP Format}
970	+	ServerName := Match.Groups[1].Value;
971	+	PortNo := Match.Groups[2].Value;
972	+	DatabaseName := Match.Groups[3].Value;
973	+	Protocol := TCP;
974	+	end
975	+	else
976	+	begin
977	+	Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
978	+	Result := Match.Success and (Match.Groups.Count = 4);
979	+	if Result then
980	+	begin
981	+	{Netbui}
982	+	ServerName := Match.Groups[1].Value;
983	+	PortNo := Match.Groups[2].Value;
984	+	DatabaseName := Match.Groups[3].Value;
985	+	Protocol := NamedPipe
986	+	end
987	+	else
988	+	begin
989	+	Result := true;
990	+	Protocol := Local; {Assume local}
991	+	end;
992	+	end;
993	+	end;
994	+	end;
995	+	end;
996	+	end;
997		{$ELSE}
998	<	{cruder version of above for old versions of Delphi}
998	>	{cruder version of above for Delphi < XE. Older versions lack regular expression
999	>	handling.}
1000		function ExtractConnectString(const CreateSQL: AnsiString;
1001		var ConnectString: AnsiString): boolean;
1002		var i: integer;
#	Line 417 | Line 1015 | begin
1015		end;
1016		end;
1017		end;
1018	<	{$ENDIF}
1018	>
1019	>	function ParseConnectString(ConnectString: AnsiString;
1020	>	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1021	>	var PortNo: AnsiString): boolean;
1022	>	begin
1023	>	Result := false;
1024	>	end;
1025	>
1026	>	{$IFEND}
1027	>	{$IFEND}
1028	>
1029	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1030	>	var ServerName,
1031	>	DatabaseName: AnsiString;
1032	>	PortNo: AnsiString;
1033	>	begin
1034	>	if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1035	>	Result := unknownProtocol;
1036	>	end;
1037	>
1038	>	{Make a connect string in format appropriate protocol}
1039	>
1040	>	function MakeConnectString(ServerName, DatabaseName: AnsiString;
1041	>	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1042	>
1043	>	function FormatURL: AnsiString;
1044	>	begin
1045	>	if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1046	>	Result := DatabaseName
1047	>	else
1048	>	Result := ServerName + '/' + DatabaseName;
1049	>	end;
1050	>
1051	>	begin
1052	>	if ServerName = '' then ServerName := 'localhost';
1053	>	if PortNo <> '' then
1054	>	case Protocol of
1055	>	NamedPipe:
1056	>	ServerName := ServerName + '@' + PortNo;
1057	>	Local,
1058	>	SPX,
1059	>	xnet: {do nothing};
1060	>	TCP:
1061	>	ServerName := ServerName + '/' + PortNo;
1062	>	else
1063	>	ServerName := ServerName + ':' + PortNo;
1064	>	end;
1065	>
1066	>	case Protocol of
1067	>	TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
1068	>	SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
1069	>	NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1070	>	Local:      Result := DatabaseName; {do not localize}
1071	>	inet:       Result := 'inet://' + FormatURL; {do not localize}
1072	>	inet4:       Result := 'inet4://' + FormatURL; {do not localize}
1073	>	inet6:       Result := 'inet6://' + FormatURL; {do not localize}
1074	>	wnet:       Result := 'wnet://' + FormatURL; {do not localize}
1075	>	xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
1076	>	end;
1077	>	end;
1078
1079		{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1080
1081		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1082		begin
1083	+	Value := TrimRight(Value);
1084		if (Dialect = 3) and
1085		(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1086		Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
#	Line 449 | Line 1107 | begin
1107		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1108		end;
1109
1110	+	{ TSQLParamProcessor }
1111	+
1112	+	function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1113	+	var slNames: TStrings): AnsiString;
1114	+	var token: TSQLTokens;
1115	+	iParamSuffix: Integer;
1116	+	begin
1117	+	Result := '';
1118	+	iParamSuffix := 0;
1119	+
1120	+	while not EOF do
1121	+	begin
1122	+	token := GetNextToken;
1123	+	case token of
1124	+	sqltParam,
1125	+	sqltQuotedParam:
1126	+	begin
1127	+	Result := Result + '?';
1128	+	slNames.Add(TokenText);
1129	+	end;
1130	+
1131	+	sqltPlaceHolder:
1132	+	if GenerateParamNames then
1133	+	begin
1134	+	Inc(iParamSuffix);
1135	+	slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1136	+	//add pointer to self to mark entry
1137	+	Result := Result + '?';
1138	+	end
1139	+	else
1140	+	IBError(ibxeSQLParseError, [SParamNameExpected]);
1141	+
1142	+	sqltQuotedString:
1143	+	Result := Result + '''' + SQLSafeString(TokenText) + '''';
1144	+
1145	+	sqltIdentifierInDoubleQuotes:
1146	+	Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1147	+
1148	+	sqltComment:
1149	+	Result := Result + '/*' + TokenText + '*/';
1150	+
1151	+	sqltCommentLine:
1152	+	Result := Result + '--' + TokenText + LineEnding;
1153	+
1154	+	sqltEOL:
1155	+	Result := Result + LineEnding;
1156	+
1157	+	else
1158	+	Result := Result + TokenText;
1159	+	end;
1160	+	end;
1161	+	end;
1162	+
1163	+	function TSQLParamProcessor.GetChar: AnsiChar;
1164	+	begin
1165	+	if FIndex <= Length(FInString) then
1166	+	begin
1167	+	Result := FInString[FIndex];
1168	+	Inc(FIndex);
1169	+	end
1170	+	else
1171	+	Result := #0;
1172	+	end;
1173	+
1174	+	class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1175	+	GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1176	+	begin
1177	+	with self.Create do
1178	+	try
1179	+	FInString := sSQL;
1180	+	FIndex := 1;
1181	+	Result := DoExecute(GenerateParamNames,slNames);
1182	+	finally
1183	+	Free;
1184	+	end;
1185	+	end;
1186	+
1187	+	{ TSQLwithNamedParamsTokeniser }
1188	+
1189	+	procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1190	+	begin
1191	+	inherited Assign(source);
1192	+	if source is TSQLwithNamedParamsTokeniser then
1193	+	begin
1194	+	FState := TSQLwithNamedParamsTokeniser(source).FState;
1195	+	FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1196	+	end;
1197	+	end;
1198	+
1199	+	procedure TSQLwithNamedParamsTokeniser.Reset;
1200	+	begin
1201	+	inherited Reset;
1202	+	FState := stInit;
1203	+	FNested := 0;
1204	+	end;
1205	+
1206	+	function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1207	+	): boolean;
1208	+	begin
1209	+	Result := inherited TokenFound(token);
1210	+	if not Result then Exit;
1211	+
1212	+	case FState of
1213	+	stInit:
1214	+	begin
1215	+	case token of
1216	+	sqltColon:
1217	+	begin
1218	+	FState := stInParam;
1219	+	ResetQueue(token);
1220	+	end;
1221	+
1222	+	sqltBegin:
1223	+	begin
1224	+	FState := stInBlock;
1225	+	FNested := 1;
1226	+	end;
1227	+
1228	+	sqltOpenSquareBracket:
1229	+	FState := stInArrayDim;
1230	+
1231	+	end;
1232	+	end;
1233	+
1234	+	stInParam:
1235	+	begin
1236	+	case token of
1237	+	sqltIdentifier:
1238	+	token := sqltParam;
1239	+
1240	+	sqltIdentifierInDoubleQuotes:
1241	+	token := sqltQuotedParam;
1242	+
1243	+	else
1244	+	begin
1245	+	QueueToken(token);
1246	+	ReleaseQueue(token);
1247	+	end;
1248	+	end;
1249	+	FState := stInit;
1250	+	end;
1251	+
1252	+	stInBlock:
1253	+	begin
1254	+	case token of
1255	+	sqltBegin,
1256	+	sqltCase:
1257	+	Inc(FNested);
1258	+
1259	+	sqltEnd:
1260	+	begin
1261	+	Dec(FNested);
1262	+	if FNested = 0 then
1263	+	FState := stInit;
1264	+	end;
1265	+	end;
1266	+	end;
1267	+
1268	+	stInArrayDim:
1269	+	begin
1270	+	if token = sqltCloseSquareBracket then
1271	+	FState := stInit;
1272	+	end;
1273	+	end;
1274	+
1275	+	Result := (FState <> stInParam);
1276	+	end;
1277	+
1278	+	{ TSQLTokeniser }
1279	+
1280	+	function TSQLTokeniser.GetNext: TSQLTokens;
1281	+	var C: AnsiChar;
1282	+	begin
1283	+	if EOF then
1284	+	Result := sqltEOF
1285	+	else
1286	+	begin
1287	+	C := GetChar;
1288	+	case C of
1289	+	#0:
1290	+	Result := sqltEOF;
1291	+	' ',TAB:
1292	+	Result := sqltSpace;
1293	+	'0'..'9':
1294	+	Result := sqltNumberString;
1295	+	';':
1296	+	Result := sqltSemiColon;
1297	+	'?':
1298	+	Result := sqltPlaceholder;
1299	+	'|':
1300	+	Result := sqltPipe;
1301	+	'"':
1302	+	Result := sqltDoubleQuotes;
1303	+	'''':
1304	+	Result := sqltSingleQuotes;
1305	+	'/':
1306	+	Result := sqltForwardSlash;
1307	+	'\':
1308	+	Result := sqltBackslash;
1309	+	'*':
1310	+	Result := sqltAsterisk;
1311	+	'(':
1312	+	Result := sqltOpenBracket;
1313	+	')':
1314	+	Result := sqltCloseBracket;
1315	+	':':
1316	+	Result := sqltColon;
1317	+	',':
1318	+	Result := sqltComma;
1319	+	'.':
1320	+	Result := sqltPeriod;
1321	+	'=':
1322	+	Result := sqltEquals;
1323	+	'[':
1324	+	Result := sqltOpenSquareBracket;
1325	+	']':
1326	+	Result := sqltCloseSquareBracket;
1327	+	'-':
1328	+	Result := sqltMinus;
1329	+	'<':
1330	+	Result := sqltLT;
1331	+	'>':
1332	+	Result := sqltGT;
1333	+	CR:
1334	+	Result := sqltCR;
1335	+	LF:
1336	+	Result := sqltEOL;
1337	+	else
1338	+	if C in ValidSQLIdentifierChars then
1339	+	Result := sqltIdentifier
1340	+	else
1341	+	Result := sqltOtherCharacter;
1342	+	end;
1343	+	FLastChar := C
1344	+	end;
1345	+	FNextToken := Result;
1346	+	end;
1347	+
1348	+	procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1349	+	begin
1350	+	if FQFirst = FQLast then
1351	+	IBError(ibxeTokenQueueUnderflow,[]);
1352	+	token := FTokenQueue[FQFirst].token;
1353	+	FString := FTokenQueue[FQFirst].text;
1354	+	Inc(FQFirst);
1355	+	if FQFirst = FQLast then
1356	+	FQueueState := tsHold;
1357	+	end;
1358	+
1359	+	procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1360	+	begin
1361	+	FString := source.FString;
1362	+	FNextToken := source.FNextToken;
1363	+	FTokenQueue := source.FTokenQueue;
1364	+	FQueueState := source.FQueueState;
1365	+	FQFirst := source.FQFirst;
1366	+	FQLast := source.FQLast;
1367	+	end;
1368	+
1369	+	function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1370	+	begin
1371	+	Result := (FState = stDefault);
1372	+	if Result and (token = sqltIdentifier)  then
1373	+	FindReservedWord(FString,token);
1374	+	end;
1375	+
1376	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1377	+	begin
1378	+	if FQLast > TokenQueueMaxSize then
1379	+	IBError(ibxeTokenQueueOverflow,[]);
1380	+	FTokenQueue[FQLast].token := token;
1381	+	FTokenQueue[FQLast].text := text;
1382	+	Inc(FQLast);
1383	+	end;
1384	+
1385	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1386	+	begin
1387	+	QueueToken(token,TokenText);
1388	+	end;
1389	+
1390	+	procedure TSQLTokeniser.ResetQueue;
1391	+	begin
1392	+	FQFirst := 0;
1393	+	FQLast := 0;
1394	+	FQueueState := tsHold;
1395	+	end;
1396	+
1397	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1398	+	begin
1399	+	ResetQueue;
1400	+	QueueToken(token,text);
1401	+	end;
1402	+
1403	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1404	+	begin
1405	+	ResetQueue;
1406	+	QueueToken(token);
1407	+	end;
1408	+
1409	+	procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1410	+	begin
1411	+	FQueueState := tsRelease;
1412	+	PopQueue(token);
1413	+	end;
1414	+
1415	+	procedure TSQLTokeniser.ReleaseQueue;
1416	+	begin
1417	+	FQueueState := tsRelease;
1418	+	end;
1419	+
1420	+	function TSQLTokeniser.GetQueuedText: AnsiString;
1421	+	var i: integer;
1422	+	begin
1423	+	Result := '';
1424	+	for i := FQFirst to FQLast do
1425	+	Result := Result + FTokenQueue[i].text;
1426	+	end;
1427	+
1428	+	procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1429	+	begin
1430	+	FString := text;
1431	+	end;
1432	+
1433	+	constructor TSQLTokeniser.Create;
1434	+	begin
1435	+	inherited Create;
1436	+	Reset;
1437	+	end;
1438	+
1439	+	destructor TSQLTokeniser.Destroy;
1440	+	begin
1441	+	Reset;
1442	+	inherited Destroy;
1443	+	end;
1444	+
1445	+	procedure TSQLTokeniser.Reset;
1446	+	begin
1447	+	FNextToken := sqltInit;
1448	+	FState := stDefault;
1449	+	FString := '';
1450	+	FEOF := false;
1451	+	ResetQueue;
1452	+	end;
1453	+
1454	+	function TSQLTokeniser.GetNextToken: TSQLTokens;
1455	+	begin
1456	+	if FQueueState = tsRelease then
1457	+	repeat
1458	+	PopQueue(Result);
1459	+	FEOF := Result = sqltEOF;
1460	+	if TokenFound(Result) then
1461	+	Exit;
1462	+	until FQueueState <> tsRelease;
1463	+
1464	+	Result := InternalGetNextToken;
1465	+	end;
1466	+
1467	+	{a simple lookahead one algorithm to extra the next symbol}
1468	+
1469	+	function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1470	+	var C: AnsiChar;
1471	+	begin
1472	+	Result := sqltEOF;
1473	+
1474	+	if FNextToken = sqltInit then
1475	+	GetNext;
1476	+
1477	+	repeat
1478	+	if FSkipNext then
1479	+	begin
1480	+	FSkipNext := false;
1481	+	GetNext;
1482	+	end;
1483	+
1484	+	Result := FNextToken;
1485	+	C := FLastChar;
1486	+	GetNext;
1487	+
1488	+	if (Result = sqltCR) and (FNextToken = sqltEOL) then
1489	+	begin
1490	+	FSkipNext := true;
1491	+	Result := sqltEOL;
1492	+	C := LF;
1493	+	end;
1494	+
1495	+	case FState of
1496	+	stInComment:
1497	+	begin
1498	+	if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1499	+	begin
1500	+	FState := stDefault;
1501	+	Result := sqltComment;
1502	+	GetNext;
1503	+	end
1504	+	else
1505	+	if Result = sqltEOL then
1506	+	FString := FString + LineEnding
1507	+	else
1508	+	FString := FString + C;
1509	+	end;
1510	+
1511	+	stInCommentLine:
1512	+	begin
1513	+	case Result of
1514	+	sqltEOL:
1515	+	begin
1516	+	FState := stDefault;
1517	+	Result := sqltCommentLine;
1518	+	end;
1519	+
1520	+	else
1521	+	FString := FString + C;
1522	+	end;
1523	+	end;
1524	+
1525	+	stSingleQuoted:
1526	+	begin
1527	+	if (Result = sqltSingleQuotes) then
1528	+	begin
1529	+	if (FNextToken = sqltSingleQuotes) then
1530	+	begin
1531	+	FSkipNext := true;
1532	+	FString := FString + C;
1533	+	end
1534	+	else
1535	+	begin
1536	+	Result := sqltQuotedString;
1537	+	FState := stDefault;
1538	+	end;
1539	+	end
1540	+	else
1541	+	if Result = sqltEOL then
1542	+	FString := FString + LineEnding
1543	+	else
1544	+	FString := FString + C;
1545	+	end;
1546	+
1547	+	stDoubleQuoted:
1548	+	begin
1549	+	if (Result = sqltDoubleQuotes) then
1550	+	begin
1551	+	if (FNextToken = sqltDoubleQuotes) then
1552	+	begin
1553	+	FSkipNext := true;
1554	+	FString := FString + C;
1555	+	end
1556	+	else
1557	+	begin
1558	+	Result := sqltIdentifierInDoubleQuotes;
1559	+	FState := stDefault;
1560	+	end;
1561	+	end
1562	+	else
1563	+	if Result = sqltEOL then
1564	+	FString := FString + LineEnding
1565	+	else
1566	+	FString := FString + C;
1567	+	end;
1568	+
1569	+	stInIdentifier:
1570	+	begin
1571	+	FString := FString + C;
1572	+	Result := sqltIdentifier;
1573	+	if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1574	+	FState := stDefault
1575	+	end;
1576	+
1577	+	stInNumeric:
1578	+	begin
1579	+	FString := FString + C;
1580	+	if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1581	+	begin
1582	+	{malformed decimal}
1583	+	FState := stInIdentifier;
1584	+	Result := sqltIdentifier
1585	+	end
1586	+	else
1587	+	begin
1588	+	if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1589	+	FState := stDefault;
1590	+	Result := sqltNumberString;
1591	+	end;
1592	+	end;
1593	+
1594	+	else {stDefault}
1595	+	begin
1596	+	FString := C;
1597	+	case Result of
1598	+
1599	+	sqltPipe:
1600	+	if FNextToken = sqltPipe then
1601	+	begin
1602	+	Result := sqltConcatSymbol;
1603	+	FString := C + FLastChar;
1604	+	GetNext;
1605	+	end;
1606	+
1607	+	sqltForwardSlash:
1608	+	begin
1609	+	if FNextToken = sqltAsterisk then
1610	+	begin
1611	+	FString := '';
1612	+	GetNext;
1613	+	FState := stInComment;
1614	+	end
1615	+	end;
1616	+
1617	+	sqltMinus:
1618	+	begin
1619	+	if FNextToken = sqltMinus then
1620	+	begin
1621	+	FString := '';
1622	+	GetNext;
1623	+	FState := stInCommentLine;
1624	+	end;
1625	+	end;
1626	+
1627	+	sqltSingleQuotes:
1628	+	begin
1629	+	FString := '';
1630	+	FState := stSingleQuoted;
1631	+	end;
1632	+
1633	+	sqltDoubleQuotes:
1634	+	begin
1635	+	FString := '';
1636	+	FState := stDoubleQuoted;
1637	+	end;
1638	+
1639	+	sqltIdentifier:
1640	+	if FNextToken in [sqltIdentifier,sqltNumberString] then
1641	+	FState := stInIdentifier;
1642	+
1643	+	sqltNumberString:
1644	+	if FNextToken in [sqltNumberString,sqltPeriod] then
1645	+	FState := stInNumeric;
1646	+
1647	+	sqltEOL:
1648	+	FString := LineEnding;
1649	+	end;
1650	+	end;
1651	+	end;
1652	+
1653	+	//    writeln(FString);
1654	+	FEOF := Result = sqltEOF;
1655	+	until TokenFound(Result) or EOF;
1656	+	end;
1657	+
1658	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1659	+	var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1660	+	{$IF declared(TFormatSettings)}
1661	+	begin
1662	+	{$IF declared(DefaultFormatSettings)}
1663	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1664	+	{$ELSE}
1665	+	{$IF declared(FormatSettings)}
1666	+	Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1667	+	{$IFEND} {$IFEND}
1668	+	end;
1669	+
1670	+	function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1671	+	var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1672	+	{$IFEND}
1673	+	const
1674	+	whitespacechars = [' ',#$09,#$0A,#$0D];
1675	+	var i,j,l: integer;
1676	+	aTime: TDateTime;
1677	+	DMs: longint;
1678	+	begin
1679	+	Result := false;
1680	+	aTimezone := '';
1681	+	if aDateTimeStr <> '' then
1682	+	{$if declared(TFormatSettings)}
1683	+	with aFormatSettings do
1684	+	{$IFEND}
1685	+	begin
1686	+	aDateTime := 0;
1687	+	{Parse to get time zone info}
1688	+	i := 1;
1689	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1690	+	if not TimeOnly then
1691	+	begin
1692	+	{decode date}
1693	+	j := i;
1694	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1695	+	if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1696	+	i := j; {otherwise start again i.e. assume time only}
1697	+	end;
1698	+
1699	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1700	+	{decode time}
1701	+	j := i;
1702	+	while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1703	+	Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1704	+	if not Result then Exit;
1705	+	aDateTime := aDateTime + aTime;
1706	+	i := j;
1707	+
1708	+	{is there a factional second part}
1709	+	if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1710	+	begin
1711	+	inc(i);
1712	+	inc(j);
1713	+	while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1714	+	if j > i then
1715	+	begin
1716	+	l := j-i;
1717	+	if l > 4 then l := 4;
1718	+	Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1719	+	if not Result then Exit;
1720	+
1721	+	{adjust for number of significant digits}
1722	+	case l of
1723	+	3:   DMs := DMs * 10;
1724	+	2:   DMs := DMs * 100;
1725	+	1:   DMs := DMs * 1000;
1726	+	end;
1727	+	aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1728	+	end;
1729	+	end;
1730	+	i := j;
1731	+
1732	+	while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1733	+	{decode time zone}
1734	+	if i < length(aDateTimeStr) then
1735	+	begin
1736	+	j := i;
1737	+	while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1738	+	aTimezone := system.copy(aDateTimeStr,i,j-i);
1739	+	end;
1740	+	Result := true;
1741	+	end
1742	+	end;
1743	+
1744	+	{The following is similar to FPC DecodeTime except that the Firebird standard
1745	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1746	+
1747	+	procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1748	+	var DeciMillisecond: cardinal);
1749	+	var D : Double;
1750	+	l : cardinal;
1751	+	begin
1752	+	{conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1753	+	D := aTime * MSecsPerDay *10;
1754	+	if D < 0 then
1755	+	D := D - 0.5
1756	+	else
1757	+	D := D + 0.5;
1758	+	{rest hacked from FPC DecodeTIme}
1759	+	l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1760	+	Hour   := l div 36000000;
1761	+	l := l mod 36000000;
1762	+	Minute := l div 600000;
1763	+	l := l mod 600000;
1764	+	Second := l div 10000;
1765	+	DeciMillisecond := l mod 10000;
1766	+	end;
1767	+
1768	+	{The following is similar to FPC EncodeTime except that the Firebird standard
1769	+	decimilliseconds is used instead of milliseconds for fractional seconds}
1770	+
1771	+	function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1772	+	const DMSecsPerDay = MSecsPerDay*10;
1773	+	var DMs: cardinal;
1774	+	D: Double;
1775	+	begin
1776	+	if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1777	+	begin
1778	+	DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1779	+	D := DMs/DMSecsPerDay;
1780	+	Result:=TDateTime(d)
1781	+	end
1782	+	else
1783	+	IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1784	+	end;
1785	+
1786	+	{The following is similar to FPC FormatDateTime except that it additionally
1787	+	allows the timstamp to have a fractional seconds component with a resolution
1788	+	of four decimal places. This is appended to the result for FormatDateTime
1789	+	if the format string contains a "zzzz' string.}
1790	+
1791	+	function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1792	+	var Hour, Minute, Second: word;
1793	+	DeciMillisecond: cardinal;
1794	+	begin
1795	+	if Pos('zzzz',fmt) > 0 then
1796	+	begin
1797	+	FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1798	+	fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1799	+	end;
1800	+	Result := FormatDateTime(fmt,aDateTime);
1801	+	end;
1802	+
1803	+	function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1804	+	begin
1805	+	if EffectiveTimeOffsetMins > 0 then
1806	+	Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1807	+	else
1808	+	Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1809	+	end;
1810	+
1811	+	function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1812	+	var i: integer;
1813	+	begin
1814	+	Result := false;
1815	+	TZOffset := Trim(TZOffset);
1816	+	for i := 1 to Length(TZOffset) do
1817	+	if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1818	+
1819	+	Result := true;
1820	+	i := Pos(':',TZOffset);
1821	+	if i > 0 then
1822	+	dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1823	+	else
1824	+	dstOffset := StrToInt(TZOffset) * 60;
1825	+	end;
1826	+
1827	+	function StripLeadingZeros(Value: AnsiString): AnsiString;
1828	+	var i: Integer;
1829	+	start: integer;
1830	+	begin
1831	+	Result := '';
1832	+	start := 1;
1833	+	if (Length(Value) > 0) and (Value[1] = '-') then
1834	+	begin
1835	+	Result := '-';
1836	+	start := 2;
1837	+	end;
1838	+	for i := start to Length(Value) do
1839	+	if Value[i] <> '0' then
1840	+	begin
1841	+	Result := Result + system.copy(Value, i, MaxInt);
1842	+	Exit;
1843	+	end;
1844	+	end;
1845	+
1846	+	function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
1847	+	var i: integer;
1848	+	ds: integer;
1849	+	exponent: integer;
1850	+	begin
1851	+	Result := false;
1852	+	ds := 0;
1853	+	exponent := 0;
1854	+	S := Trim(S);
1855	+	Value := 0;
1856	+	scale := 0;
1857	+	if Length(S) = 0 then
1858	+	Exit;
1859	+	{$IF declared(DefaultFormatSettings)}
1860	+	with DefaultFormatSettings do
1861	+	{$ELSE}
1862	+	{$IF declared(FormatSettings)}
1863	+	with FormatSettings do
1864	+	{$IFEND}
1865	+	{$IFEND}
1866	+	begin
1867	+	for i := length(S) downto 1 do
1868	+	begin
1869	+	if S[i] = AnsiChar(DecimalSeparator) then
1870	+	begin
1871	+	if ds <> 0 then Exit; {only one allowed}
1872	+	ds := i;
1873	+	dec(exponent);
1874	+	system.Delete(S,i,1);
1875	+	end
1876	+	else
1877	+	if S[i] in ['+','-'] then
1878	+	begin
1879	+	if (i > 1) and not (S[i-1] in ['e','E']) then
1880	+	Exit; {malformed}
1881	+	end
1882	+	else
1883	+	if S[i] in ['e','E'] then {scientific notation}
1884	+	begin
1885	+	if ds <> 0 then Exit; {not permitted in exponent}
1886	+	if exponent <> 0 then Exit; {only one allowed}
1887	+	exponent := i;
1888	+	end
1889	+	else
1890	+	if not (S[i] in ['0'..'9']) then
1891	+	{Note: ThousandSeparator not allowed by Delphi specs}
1892	+	Exit; {bad character}
1893	+	end;
1894	+
1895	+	if exponent > 0 then
1896	+	begin
1897	+	Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1898	+	if Result then
1899	+	begin
1900	+	{adjust scale for decimal point}
1901	+	if ds <> 0 then
1902	+	Scale := Scale - (exponent - ds);
1903	+	Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1904	+	end;
1905	+	end
1906	+	else
1907	+	begin
1908	+	if ds <> 0 then
1909	+	scale := ds - Length(S) - 1;
1910	+	Result := TryStrToInt64(S,Value);
1911	+	end;
1912	+	end;
1913	+	end;
1914	+
1915	+	function NumericToDouble(aValue: Int64; aScale: integer): double;
1916	+	begin
1917	+	Result := aValue * IntPower(10,aScale)
1918	+	end;
1919	+
1920		end.

Diff Legend

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