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 118 by tony, Mon Jan 22 13:58:14 2018 UTC vs.
ibx/branches/journaling/fbintf/IBUtils.pas (file contents), Revision 362 by tony, Tue Dec 7 13:27:39 2021 UTC

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

Diff Legend

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