ViewVC Help

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

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

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 56 by tony, Mon Mar 6 10:20:02 2017 UTC vs.
Revision 311 by tony, Mon Aug 24 09:32:58 2020 UTC

#	Line 33 | Line 33
33
34		unit IBUtils;
35		{$IFDEF MSWINDOWS}
36	<	{$DEFINE WINDOWS}
36	>	{$DEFINE WINDOWS}
37		{$ENDIF}
38
39		{$IFDEF FPC}
40		{$Mode Delphi}
41		{$codepage UTF8}
42	+	{$define HASREQEX}
43		{$ENDIF}
44
45	+
46		interface
47
48	<	uses Classes, SysUtils;
48	>	uses Classes, SysUtils, IB;
49	>
50	>	type
51	>	TSQLTokens = (
52	>
53	>	{Reserved Words}
54	>
55	>	sqltAdd,
56	>	sqltAdmin,
57	>	sqltAll,
58	>	sqltAlter,
59	>	sqltAnd,
60	>	sqltAny,
61	>	sqltAs,
62	>	sqltAt,
63	>	sqltAvg,
64	>	sqltBegin,
65	>	sqltBetween,
66	>	sqltBigint,
67	>	sqltBit_Length,
68	>	sqltBlob,
69	>	sqltBoolean,
70	>	sqltBoth,
71	>	sqltBy,
72	>	sqltCase,
73	>	sqltCast,
74	>	sqltChar,
75	>	sqltChar_Length,
76	>	sqltCharacter,
77	>	sqltCharacter_Length,
78	>	sqltCheck,
79	>	sqltClose,
80	>	sqltCollate,
81	>	sqltColumn,
82	>	sqltCommit,
83	>	sqltConnect,
84	>	sqltConstraint,
85	>	sqltCorr,
86	>	sqltCount,
87	>	sqltCovar_Pop,
88	>	sqltCovar_Samp,
89	>	sqltCreate,
90	>	sqltCross,
91	>	sqltCurrent,
92	>	sqltCurrent_Connection,
93	>	sqltCurrent_Date,
94	>	sqltCurrent_Role,
95	>	sqltCurrent_Time,
96	>	sqltCurrent_Timestamp,
97	>	sqltCurrent_Transaction,
98	>	sqltCurrent_User,
99	>	sqltCursor,
100	>	sqltDate,
101	>	sqltDay,
102	>	sqltDec,
103	>	sqltDecimal,
104	>	sqltDeclare,
105	>	sqltDefault,
106	>	sqltDelete,
107	>	sqltDeleting,
108	>	sqltDeterministic,
109	>	sqltDisconnect,
110	>	sqltDistinct,
111	>	sqltDouble,
112	>	sqltDrop,
113	>	sqltElse,
114	>	sqltEnd,
115	>	sqltEscape,
116	>	sqltExecute,
117	>	sqltExists,
118	>	sqltExternal,
119	>	sqltExtract,
120	>	sqltFalse,
121	>	sqltFetch,
122	>	sqltFilter,
123	>	sqltFloat,
124	>	sqltFor,
125	>	sqltForeign,
126	>	sqltFrom,
127	>	sqltFull,
128	>	sqltFunction,
129	>	sqltGdscode,
130	>	sqltGlobal,
131	>	sqltGrant,
132	>	sqltGroup,
133	>	sqltHaving,
134	>	sqltHour,
135	>	sqltIn,
136	>	sqltIndex,
137	>	sqltInner,
138	>	sqltInsensitive,
139	>	sqltInsert,
140	>	sqltInserting,
141	>	sqltInt,
142	>	sqltInteger,
143	>	sqltInto,
144	>	sqltIs,
145	>	sqltJoin,
146	>	sqltKey,
147	>	sqltLeading,
148	>	sqltLeft,
149	>	sqltLike,
150	>	sqltLong,
151	>	sqltLower,
152	>	sqltMax,
153	>	sqltMaximum_Segment,
154	>	sqltMerge,
155	>	sqltMin,
156	>	sqltMinute,
157	>	sqltMonth,
158	>	sqltNational,
159	>	sqltNatural,
160	>	sqltNchar,
161	>	sqltNo,
162	>	sqltNot,
163	>	sqltNull,
164	>	sqltNumeric,
165	>	sqltOctet_Length,
166	>	sqltOf,
167	>	sqltOffset,
168	>	sqltOn,
169	>	sqltOnly,
170	>	sqltOpen,
171	>	sqltOr,
172	>	sqltOrder,
173	>	sqltOuter,
174	>	sqltOver,
175	>	sqltParameter,
176	>	sqltPlan,
177	>	sqltPosition,
178	>	sqltPost_Event,
179	>	sqltPrecision,
180	>	sqltPrimary,
181	>	sqltProcedure,
182	>	sqltRdbDb_Key,
183	>	sqltRdbRecord_Version,
184	>	sqltReal,
185	>	sqltRecord_Version,
186	>	sqltRecreate,
187	>	sqltRecursive,
188	>	sqltReferences,
189	>	sqltRegr_Avgx,
190	>	sqltRegr_Avgy,
191	>	sqltRegr_Count,
192	>	sqltRegr_Intercept,
193	>	sqltRegr_R2,
194	>	sqltRegr_Slope,
195	>	sqltRegr_Sxx,
196	>	sqltRegr_Sxy,
197	>	sqltRegr_Syy,
198	>	sqltRelease,
199	>	sqltReturn,
200	>	sqltReturning_Values,
201	>	sqltReturns,
202	>	sqltRevoke,
203	>	sqltRight,
204	>	sqltRollback,
205	>	sqltRow,
206	>	sqltRows,
207	>	sqltRow_Count,
208	>	sqltSavepoint,
209	>	sqltScroll,
210	>	sqltSecond,
211	>	sqltSelect,
212	>	sqltSensitive,
213	>	sqltSet,
214	>	sqltSimilar,
215	>	sqltSmallint,
216	>	sqltSome,
217	>	sqltSqlcode,
218	>	sqltSqlstate,
219	>	sqltStart,
220	>	sqltStddev_Pop,
221	>	sqltStddev_Samp,
222	>	sqltSum,
223	>	sqltTable,
224	>	sqltThen,
225	>	sqltTime,
226	>	sqltTimestamp,
227	>	sqltTo,
228	>	sqltTrailing,
229	>	sqltTrigger,
230	>	sqltTrim,
231	>	sqltTrue,
232	>	sqltUnion,
233	>	sqltUnique,
234	>	sqltUnknown,
235	>	sqltUpdate,
236	>	sqltUpdating,
237	>	sqltUpper,
238	>	sqltUser,
239	>	sqltUsing,
240	>	sqltValue,
241	>	sqltValues,
242	>	sqltVar_Pop,
243	>	sqltVar_Samp,
244	>	sqltVarchar,
245	>	sqltVariable,
246	>	sqltVarying,
247	>	sqltView,
248	>	sqltWhen,
249	>	sqltWhere,
250	>	sqltWhile,
251	>	sqltWith,
252	>	sqltYear,
253	>
254	>	{symbols}
255	>
256	>	sqltSpace,
257	>	sqltSemiColon,
258	>	sqltPlaceholder,
259	>	sqltSingleQuotes,
260	>	sqltDoubleQuotes,
261	>	sqltBackslash,
262	>	sqltComma,
263	>	sqltPeriod,
264	>	sqltEquals,
265	>	sqltOtherCharacter,
266	>	sqltIdentifier,
267	>	sqltIdentifierInDoubleQuotes,
268	>	sqltNumberString,
269	>	sqltString,
270	>	sqltParam,
271	>	sqltQuotedParam,
272	>	sqltColon,
273	>	sqltComment,
274	>	sqltCommentLine,
275	>	sqltQuotedString,
276	>	sqltAsterisk,
277	>	sqltForwardSlash,
278	>	sqltOpenSquareBracket,
279	>	sqltCloseSquareBracket,
280	>	sqltOpenBracket,
281	>	sqltCloseBracket,
282	>	sqltPipe,
283	>	sqltMinus,
284	>	sqltConcatSymbol,
285	>	sqltLT,
286	>	sqltGT,
287	>	sqltCR,
288	>	sqltEOL,
289	>	sqltEOF,
290	>	sqltInit
291	>	);
292	>
293	>	TSQLReservedWords = sqltAdd..sqltYear;
294
295		const
296		CRLF = #13 + #10;
#	Line 52 | Line 299 | const
299		TAB  = #9;
300		NULL_TERMINATOR = #0;
301
302	<	sqlReservedWords: array [0..197] of string = (
302	>	{$IFNDEF FPC}
303	>	LineEnding = CRLF;
304	>	{$ENDIF}
305	>
306	>	{SQL Reserved words in alphabetical order}
307	>
308	>	sqlReservedWords: array [TSQLReservedWords] of string = (
309		'ADD',
310		'ADMIN',
311		'ALL',
#	Line 144 | Line 397 | const
397		'INTO',
398		'IS',
399		'JOIN',
400	+	'KEY',
401		'LEADING',
402		'LEFT',
403		'LIKE',
#	Line 203 | Line 457 | const
457		'RIGHT',
458		'ROLLBACK',
459		'ROW',
206	–	'ROW_COUNT',
460		'ROWS',
461	+	'ROW_COUNT',
462		'SAVEPOINT',
463		'SCROLL',
464		'SECOND',
#	Line 216 | Line 470 | const
470		'SOME',
471		'SQLCODE',
472		'SQLSTATE',
219	–	'SQLSTATE',
473		'START',
474		'STDDEV_POP',
475		'STDDEV_SAMP',
#	Line 253 | Line 506 | const
506		'YEAR'
507		);
508
509	+	type
510	+	{The TSQLTokeniser class provides a common means to parse an SQL statement, or
511	+	even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
512	+	with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
513	+	is instantiated with a stream from which the SQL statements are read.
514	+
515	+	Successive calls to GetNextToken then return each SQL token. The TokenText contains
516	+	either the single character, the identifier or reserved word, the string or comment.}
517	+
518	+	{ TSQLTokeniser }
519	+
520	+	TSQLTokeniser = class
521	+	private
522	+	const
523	+	TokenQueueMaxSize = 64;
524	+	type
525	+	TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
526	+	stInIdentifier, stInNumeric);
527	+
528	+	TTokenQueueItem = record
529	+	token: TSQLTokens;
530	+	text: AnsiString;
531	+	end;
532	+	TTokenQueueState = (tsHold, tsRelease);
533	+
534	+	private
535	+	FLastChar: AnsiChar;
536	+	FState: TLexState;
537	+	FSkipNext: boolean;
538	+	function GetNext: TSQLTokens;
539	+
540	+	{The token Queue is available for use by descendents so that they can
541	+	hold back tokens in order to lookahead by token rather than just a single
542	+	character}
543	+
544	+	private
545	+	FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
546	+	FQueueState: TTokenQueueState;
547	+	FQFirst: integer;  {first and last pointers first=last => queue empty}
548	+	FQLast: integer;
549	+	FEOF: boolean;
550	+	procedure PopQueue(var token: TSQLTokens);
551	+	protected
552	+	FString: AnsiString;
553	+	FNextToken: TSQLTokens;
554	+	procedure Assign(source: TSQLTokeniser); virtual;
555	+	function GetChar: AnsiChar; virtual; abstract;
556	+	function TokenFound(var token: TSQLTokens): boolean; virtual;
557	+	function InternalGetNextToken: TSQLTokens; virtual;
558	+	procedure Reset; virtual;
559	+
560	+	{Token stack}
561	+	procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
562	+	procedure QueueToken(token: TSQLTokens); overload;
563	+	procedure ResetQueue; overload;
564	+	procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
565	+	procedure ResetQueue(token: TSQLTokens); overload;
566	+	procedure ReleaseQueue(var token: TSQLTokens); overload;
567	+	procedure ReleaseQueue; overload;
568	+	function GetQueuedText: AnsiString;
569	+	procedure SetTokenText(text: AnsiString);
570	+
571	+	public
572	+	const
573	+	DefaultTerminator = ';';
574	+	public
575	+	constructor Create;
576	+	destructor Destroy; override;
577	+	function GetNextToken: TSQLTokens;
578	+	property EOF: boolean read FEOF;
579	+	property TokenText: AnsiString read FString;
580	+	end;
581	+
582	+	{ TSQLwithNamedParamsTokeniser }
583	+
584	+	TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
585	+	private
586	+	type
587	+	TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
588	+	private
589	+	FState: TSQLState;
590	+	FNested: integer;
591	+	protected
592	+	procedure Assign(source: TSQLTokeniser); override;
593	+	procedure Reset; override;
594	+	function TokenFound(var token: TSQLTokens): boolean; override;
595	+	end;
596	+
597	+	{ TSQLParamProcessor }
598	+
599	+	TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
600	+	private
601	+	const
602	+	sIBXParam = 'IBXParam';  {do not localize}
603	+	private
604	+	FInString: AnsiString;
605	+	FIndex: integer;
606	+	function DoExecute(GenerateParamNames: boolean;
607	+	var slNames: TStrings): AnsiString;
608	+	protected
609	+	function GetChar: AnsiChar; override;
610	+	public
611	+	class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
612	+	var slNames: TStrings): AnsiString;
613	+	end;
614	+
615	+
616		function Max(n1, n2: Integer): Integer;
617		function Min(n1, n2: Integer): Integer;
618		function RandomString(iLength: Integer): AnsiString;
619		function RandomInteger(iLow, iHigh: Integer): Integer;
620		function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
261	–	function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
262	–	function FormatIdentifierValue(Dialect: Integer; Value: AnsiString): AnsiString;
263	–	function FormatIdentifierValueNC(Dialect: Integer; Value: AnsiString): AnsiString;
621		function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
622	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
623	+	function IsReservedWord(w: AnsiString): boolean;
624		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
625		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
626		function Space2Underscore(s: AnsiString): AnsiString;
627		function SQLSafeString(const s: AnsiString): AnsiString;
628	+	function IsSQLIdentifier(Value: AnsiString): boolean;
629	+	function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
630	+	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
631	+	PortNo: AnsiString = ''): AnsiString;
632	+	function ParseConnectString(ConnectString: AnsiString;
633	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
634	+	var PortNo: AnsiString): boolean;
635	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
636
637		implementation
638
639	+	uses FBMessages
640	+
641	+	{$IFDEF HASREQEX}
642	+	,RegExpr
643	+	{$ENDIF};
644	+
645		function Max(n1, n2: Integer): Integer;
646		begin
647		if (n1 > n2) then
#	Line 310 | Line 683 | begin
683		end;
684		end;
685
686	<	function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
314	<	begin
315	<	Value := Trim(Value);
316	<	if Dialect = 1 then
317	<	Value := AnsiUpperCase(Value)
318	<	else
319	<	if (Value <> '') and (Value[1] = '"') then
320	<	Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
321	<	else
322	<	Value := AnsiUpperCase(Value);
323	<	Result := Value;
324	<	end;
686	>	{Extracts SQL Identifier typically from a  Dialect 3 encoding}
687
688	<	function FormatIdentifierValue(Dialect: Integer; Value: AnsiString): AnsiString;
688	>	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
689		begin
690		Value := Trim(Value);
691		if Dialect = 1 then
#	Line 342 | Line 704 | begin
704		Result := Value;
705		end;
706
707	<	function FormatIdentifierValueNC(Dialect: Integer; Value: AnsiString): AnsiString;
707	>	{Returns true if "w" is a Firebird SQL reserved word, and the
708	>	corresponding TSQLTokens value.}
709	>
710	>	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
711	>	var i: TSQLTokens;
712	>	begin
713	>	Result := true;
714	>	w := AnsiUpperCase(Trim(w));
715	>	for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
716	>	begin
717	>	if w = sqlReservedWords[i] then
718	>	begin
719	>	token := i;
720	>	Exit;
721	>	end;
722	>	if w <  sqlReservedWords[i] then
723	>	break;
724	>	end;
725	>	Result := false;
726	>	end;
727	>
728	>	{Returns true if "w" is a Firebird SQL reserved word}
729	>
730	>	function IsReservedWord(w: AnsiString): boolean;
731	>	var token: TSQLTokens;
732		begin
733	<	Value := Trim(Value);
733	>	Result := FindReservedWord(w,token);
734	>	end;
735	>
736	>	{Format an SQL Identifier according to SQL Dialect}
737	>
738	>	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
739	>	begin
740	>	Value := TrimRight(Value);
741		if Dialect = 1 then
742		Value := AnsiUpperCase(Value)
743		else
744	+	Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
745	+	Result := Value;
746	+	end;
747	+
748	+	const
749	+	ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
750	+
751	+	{Returns true if the value is a valid SQL Identifier - note lower case accepted}
752	+
753	+	function IsSQLIdentifier(Value: AnsiString): boolean;
754	+	var i: integer;
755	+	begin
756	+	Result := false;
757	+	for i := 1 to Length(Value) do
758	+	if not (Value[i] in ValidSQLIdentifierChars) then Exit;
759	+	Result := true;
760	+	end;
761	+
762	+	{Extracts the Database Connect string from a Create Database Statement}
763	+
764	+	{$IFDEF HASREQEX}
765	+	function ExtractConnectString(const CreateSQL: AnsiString;
766	+	var ConnectString: AnsiString): boolean;
767	+	var RegexObj: TRegExpr;
768	+	begin
769	+	RegexObj := TRegExpr.Create;
770	+	try
771	+	{extact database file spec}
772	+	RegexObj.ModifierG := false; {turn off greedy matches}
773	+	RegexObj.ModifierI := true; {case insensitive match}
774	+	RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
775	+	Result := RegexObj.Exec(CreateSQL);
776	+	if Result then
777	+	ConnectString := RegexObj.Match[2];
778	+	finally
779	+	RegexObj.Free;
780	+	end;
781	+	end;
782	+
783	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
784	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
785	+	): boolean;
786	+
787	+	function GetProtocol(scheme: AnsiString): TProtocolAll;
788		begin
789	<	if (Value <> '') and (Value[1] = '"') then
789	>	scheme := AnsiUpperCase(scheme);
790	>	if scheme = 'INET' then
791	>	Result := inet
792	>	else
793	>	if scheme = 'INET4' then
794	>	Result := inet4
795	>	else
796	>	if scheme = 'INET6' then
797	>	Result := inet6
798	>	else
799	>	if scheme = 'XNET' then
800	>	Result := xnet
801	>	else
802	>	if scheme = 'WNET' then
803	>	Result := wnet
804	>	end;
805	>
806	>	var RegexObj: TRegExpr;
807	>	begin
808	>	ServerName := '';
809	>	DatabaseName := ConnectString;
810	>	PortNo := '';
811	>	Protocol := unknownProtocol;
812	>	RegexObj := TRegExpr.Create;
813	>	try
814	>	{extact database file spec}
815	>	RegexObj.ModifierG := false; {turn off greedy matches}
816	>	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
817	>	Result := RegexObj.Exec(ConnectString);
818	>	if Result then
819		begin
820	<	Delete(Value, 1, 1);
821	<	Delete(Value, Length(Value), 1);
822	<	Value := AnsiUpperCase(StringReplace (Value, '""', '"', [rfReplaceAll]));
820	>	{URL type connect string}
821	>	Protocol := GetProtocol(RegexObj.Match[1]);
822	>	ServerName := RegexObj.Match[2];
823	>	if RegexObj.MatchLen[3] > 0 then
824	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
825	>	DatabaseName := RegexObj.Match[4];
826	>	if ServerName = '' then
827	>	DatabaseName := '/' + DatabaseName;
828		end
829		else
830	<	Value := AnsiUpperCase(Value);
830	>	begin
831	>	{URL type connect string - local loop}
832	>	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
833	>	Result := RegexObj.Exec(ConnectString);
834	>	if Result then
835	>	begin
836	>	Protocol := GetProtocol(RegexObj.Match[1]);
837	>	DatabaseName := RegexObj.Match[2];
838	>	end
839	>	else
840	>	begin
841	>	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
842	>	Result := RegexObj.Exec(ConnectString);
843	>	if Result then
844	>	Protocol := Local {Windows with leading drive ID}
845	>	else
846	>	begin
847	>	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
848	>	Result := RegexObj.Exec(ConnectString);
849	>	if Result then
850	>	begin
851	>	{Legacy TCP Format}
852	>	ServerName := RegexObj.Match[1];
853	>	if RegexObj.MatchLen[2] > 0 then
854	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
855	>	DatabaseName := RegexObj.Match[3];
856	>	Protocol := TCP;
857	>	end
858	>	else
859	>	begin
860	>	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
861	>	Result := RegexObj.Exec(ConnectString);
862	>	if Result then
863	>	begin
864	>	{Netbui}
865	>	ServerName := RegexObj.Match[1];
866	>	if RegexObj.MatchLen[2] > 0 then
867	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
868	>	DatabaseName := RegexObj.Match[3];
869	>	Protocol := NamedPipe
870	>	end
871	>	else
872	>	begin
873	>	Result := true;
874	>	Protocol := Local; {Assume local}
875	>	end;
876	>	end;
877	>	end;
878	>	end;
879	>	end;
880	>	finally
881	>	RegexObj.Free;
882		end;
361	–	Result := Value;
883		end;
884
885	<	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
885	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
886	>	var ServerName,
887	>	DatabaseName: AnsiString;
888	>	PortNo: AnsiString;
889		begin
890	<	Value := Trim(Value);
891	<	if Dialect = 1 then
892	<	Value := AnsiUpperCase(Value)
893	<	else
890	>	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
891	>	end;
892	>
893	>	{$ELSE}
894	>	{cruder version of above for Delphi. Older versions lack regular expression
895	>	handling.}
896	>	function ExtractConnectString(const CreateSQL: AnsiString;
897	>	var ConnectString: AnsiString): boolean;
898	>	var i: integer;
899	>	begin
900	>	Result := false;
901	>	i := Pos('''',CreateSQL);
902	>	if i > 0 then
903		begin
904	<	if (Value <> '') and (Value[1] = '"') then
904	>	ConnectString := CreateSQL;
905	>	delete(ConnectString,1,i);
906	>	i := Pos('''',ConnectString);
907	>	if i > 0 then
908		begin
909	<	Delete(Value, 1, 1);
910	<	Delete(Value, Length(Value), 1);
911	<	Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
376	<	end
377	<	else
378	<	Value := AnsiUpperCase(Value);
909	>	delete(ConnectString,i,Length(ConnectString)-i+1);
910	>	Result := true;
911	>	end;
912		end;
380	–	Result := Value;
913		end;
914
915	<	function IsReservedWord(w: AnsiString): boolean;
384	<	var i: integer;
915	>	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
916		begin
917	<	Result := true;
387	<	for i := 0 to Length(sqlReservedWords) - 1 do
388	<	if w = sqlReservedWords[i] then
389	<	Exit;
390	<	Result := false;
917	>	Result := unknownProtocol; {not implemented for Delphi}
918		end;
919
920	<	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
920	>	function ParseConnectString(ConnectString: AnsiString;
921	>	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
922	>	var PortNo: AnsiString): boolean;
923		begin
924	<	if Dialect = 1 then
925	<	Value := AnsiUpperCase(Trim(Value))
926	<	else
927	<	Value := '"' + Value + '"';
928	<	Result := Value;
924	>	Result := false;
925	>	end;
926	>
927	>	{$ENDIF}
928	>
929	>	{Make a connect string in format appropriate protocol}
930	>
931	>	function MakeConnectString(ServerName, DatabaseName: AnsiString;
932	>	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
933	>
934	>	function FormatURL: AnsiString;
935	>	begin
936	>	if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
937	>	Result := DatabaseName
938	>	else
939	>	Result := ServerName + '/' + DatabaseName;
940	>	end;
941	>
942	>	begin
943	>	if PortNo <> '' then
944	>	case Protocol of
945	>	NamedPipe:
946	>	ServerName := ServerName + '@' + PortNo;
947	>	Local,
948	>	SPX,
949	>	xnet: {do nothing};
950	>	TCP:
951	>	ServerName := ServerName + '/' + PortNo;
952	>	else
953	>	ServerName := ServerName + ':' + PortNo;
954	>	end;
955	>
956	>	case Protocol of
957	>	TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
958	>	SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
959	>	NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
960	>	Local:      Result := DatabaseName; {do not localize}
961	>	inet:       Result := 'inet://' + FormatURL; {do not localize}
962	>	inet4:       Result := 'inet4://' + FormatURL; {do not localize}
963	>	inet6:       Result := 'inet6://' + FormatURL; {do not localize}
964	>	wnet:       Result := 'wnet://' + FormatURL; {do not localize}
965	>	xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
966	>	end;
967		end;
968
969	+	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
970	+
971		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
972		begin
973	+	Value := TrimRight(Value);
974		if (Dialect = 3) and
975	<	((AnsiUpperCase(Value) <> Value) or IsReservedWord(Value)) then
976	<	Result := '"' + Value + '"'
975	>	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
976	>	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
977		else
978		Result := Value
979		end;
980
981	+	{Replaces unknown characters in a string with underscores}
982	+
983		function Space2Underscore(s: AnsiString): AnsiString;
984		var
985		k: integer;
986		begin
987		Result := s;
988		for k := 1 to Length(s) do
989	<	if not (Result[k] in ['0'..'9','A'..'Z','_','$'])  then
989	>	if not (Result[k] in ValidSQLIdentifierChars)  then
990		Result[k] := '_';
991		end;
992
993	+	{Reformats an SQL string with single quotes duplicated.}
994	+
995		function SQLSafeString(const s: AnsiString): AnsiString;
996		begin
997		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
998		end;
999
1000	+	{ TSQLParamProcessor }
1001	+
1002	+	function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1003	+	var slNames: TStrings): AnsiString;
1004	+	var token: TSQLTokens;
1005	+	iParamSuffix: Integer;
1006	+	begin
1007	+	Result := '';
1008	+	iParamSuffix := 0;
1009	+
1010	+	while not EOF do
1011	+	begin
1012	+	token := GetNextToken;
1013	+	case token of
1014	+	sqltParam,
1015	+	sqltQuotedParam:
1016	+	begin
1017	+	Result := Result + '?';
1018	+	slNames.Add(TokenText);
1019	+	end;
1020	+
1021	+	sqltPlaceHolder:
1022	+	if GenerateParamNames then
1023	+	begin
1024	+	Inc(iParamSuffix);
1025	+	slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1026	+	//add pointer to self to mark entry
1027	+	Result := Result + '?';
1028	+	end
1029	+	else
1030	+	IBError(ibxeSQLParseError, [SParamNameExpected]);
1031	+
1032	+	sqltQuotedString:
1033	+	Result := Result + '''' + SQLSafeString(TokenText) + '''';
1034	+
1035	+	sqltIdentifierInDoubleQuotes:
1036	+	Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1037	+
1038	+	sqltComment:
1039	+	Result := Result + '/*' + TokenText + '*/';
1040	+
1041	+	sqltCommentLine:
1042	+	Result := Result + '--' + TokenText + LineEnding;
1043	+
1044	+	sqltEOL:
1045	+	Result := Result + LineEnding;
1046	+
1047	+	else
1048	+	Result := Result + TokenText;
1049	+	end;
1050	+	end;
1051	+	end;
1052	+
1053	+	function TSQLParamProcessor.GetChar: AnsiChar;
1054	+	begin
1055	+	if FIndex <= Length(FInString) then
1056	+	begin
1057	+	Result := FInString[FIndex];
1058	+	Inc(FIndex);
1059	+	end
1060	+	else
1061	+	Result := #0;
1062	+	end;
1063	+
1064	+	class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1065	+	GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1066	+	begin
1067	+	with self.Create do
1068	+	try
1069	+	FInString := sSQL;
1070	+	FIndex := 1;
1071	+	Result := DoExecute(GenerateParamNames,slNames);
1072	+	finally
1073	+	Free;
1074	+	end;
1075	+	end;
1076	+
1077	+	{ TSQLwithNamedParamsTokeniser }
1078	+
1079	+	procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1080	+	begin
1081	+	inherited Assign(source);
1082	+	if source is TSQLwithNamedParamsTokeniser then
1083	+	begin
1084	+	FState := TSQLwithNamedParamsTokeniser(source).FState;
1085	+	FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1086	+	end;
1087	+	end;
1088	+
1089	+	procedure TSQLwithNamedParamsTokeniser.Reset;
1090	+	begin
1091	+	inherited Reset;
1092	+	FState := stInit;
1093	+	FNested := 0;
1094	+	end;
1095	+
1096	+	function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1097	+	): boolean;
1098	+	begin
1099	+	Result := inherited TokenFound(token);
1100	+	if not Result then Exit;
1101	+
1102	+	case FState of
1103	+	stInit:
1104	+	begin
1105	+	case token of
1106	+	sqltColon:
1107	+	begin
1108	+	FState := stInParam;
1109	+	ResetQueue(token);
1110	+	end;
1111	+
1112	+	sqltBegin:
1113	+	begin
1114	+	FState := stInBlock;
1115	+	FNested := 1;
1116	+	end;
1117	+
1118	+	sqltOpenSquareBracket:
1119	+	FState := stInArrayDim;
1120	+
1121	+	end;
1122	+	end;
1123	+
1124	+	stInParam:
1125	+	begin
1126	+	case token of
1127	+	sqltIdentifier:
1128	+	token := sqltParam;
1129	+
1130	+	sqltIdentifierInDoubleQuotes:
1131	+	token := sqltQuotedParam;
1132	+
1133	+	else
1134	+	begin
1135	+	QueueToken(token);
1136	+	ReleaseQueue(token);
1137	+	end;
1138	+	end;
1139	+	FState := stInit;
1140	+	end;
1141	+
1142	+	stInBlock:
1143	+	begin
1144	+	case token of
1145	+	sqltBegin:
1146	+	Inc(FNested);
1147	+
1148	+	sqltEnd:
1149	+	begin
1150	+	Dec(FNested);
1151	+	if FNested = 0 then
1152	+	FState := stInit;
1153	+	end;
1154	+	end;
1155	+	end;
1156	+
1157	+	stInArrayDim:
1158	+	begin
1159	+	if token = sqltCloseSquareBracket then
1160	+	FState := stInit;
1161	+	end;
1162	+	end;
1163	+
1164	+	Result := (FState <> stInParam);
1165	+	end;
1166	+
1167	+	{ TSQLTokeniser }
1168	+
1169	+	function TSQLTokeniser.GetNext: TSQLTokens;
1170	+	var C: AnsiChar;
1171	+	begin
1172	+	if EOF then
1173	+	Result := sqltEOF
1174	+	else
1175	+	begin
1176	+	C := GetChar;
1177	+	case C of
1178	+	#0:
1179	+	Result := sqltEOF;
1180	+	' ',TAB:
1181	+	Result := sqltSpace;
1182	+	'0'..'9':
1183	+	Result := sqltNumberString;
1184	+	';':
1185	+	Result := sqltSemiColon;
1186	+	'?':
1187	+	Result := sqltPlaceholder;
1188	+	'|':
1189	+	Result := sqltPipe;
1190	+	'"':
1191	+	Result := sqltDoubleQuotes;
1192	+	'''':
1193	+	Result := sqltSingleQuotes;
1194	+	'/':
1195	+	Result := sqltForwardSlash;
1196	+	'\':
1197	+	Result := sqltBackslash;
1198	+	'*':
1199	+	Result := sqltAsterisk;
1200	+	'(':
1201	+	Result := sqltOpenBracket;
1202	+	')':
1203	+	Result := sqltCloseBracket;
1204	+	':':
1205	+	Result := sqltColon;
1206	+	',':
1207	+	Result := sqltComma;
1208	+	'.':
1209	+	Result := sqltPeriod;
1210	+	'=':
1211	+	Result := sqltEquals;
1212	+	'[':
1213	+	Result := sqltOpenSquareBracket;
1214	+	']':
1215	+	Result := sqltCloseSquareBracket;
1216	+	'-':
1217	+	Result := sqltMinus;
1218	+	'<':
1219	+	Result := sqltLT;
1220	+	'>':
1221	+	Result := sqltGT;
1222	+	CR:
1223	+	Result := sqltCR;
1224	+	LF:
1225	+	Result := sqltEOL;
1226	+	else
1227	+	if C in ValidSQLIdentifierChars then
1228	+	Result := sqltIdentifier
1229	+	else
1230	+	Result := sqltOtherCharacter;
1231	+	end;
1232	+	FLastChar := C
1233	+	end;
1234	+	FNextToken := Result;
1235	+	end;
1236	+
1237	+	procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1238	+	begin
1239	+	if FQFirst = FQLast then
1240	+	IBError(ibxeTokenQueueUnderflow,[]);
1241	+	token := FTokenQueue[FQFirst].token;
1242	+	FString := FTokenQueue[FQFirst].text;
1243	+	Inc(FQFirst);
1244	+	if FQFirst = FQLast then
1245	+	FQueueState := tsHold;
1246	+	end;
1247	+
1248	+	procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1249	+	begin
1250	+	FString := source.FString;
1251	+	FNextToken := source.FNextToken;
1252	+	FTokenQueue := source.FTokenQueue;
1253	+	FQueueState := source.FQueueState;
1254	+	FQFirst := source.FQFirst;
1255	+	FQLast := source.FQLast;
1256	+	end;
1257	+
1258	+	function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1259	+	begin
1260	+	Result := (FState = stDefault);
1261	+	if Result and (token = sqltIdentifier)  then
1262	+	FindReservedWord(FString,token);
1263	+	end;
1264	+
1265	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1266	+	begin
1267	+	if FQLast > TokenQueueMaxSize then
1268	+	IBError(ibxeTokenQueueOverflow,[]);
1269	+	FTokenQueue[FQLast].token := token;
1270	+	FTokenQueue[FQLast].text := text;
1271	+	Inc(FQLast);
1272	+	end;
1273	+
1274	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1275	+	begin
1276	+	QueueToken(token,TokenText);
1277	+	end;
1278	+
1279	+	procedure TSQLTokeniser.ResetQueue;
1280	+	begin
1281	+	FQFirst := 0;
1282	+	FQLast := 0;
1283	+	FQueueState := tsHold;
1284	+	end;
1285	+
1286	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1287	+	begin
1288	+	ResetQueue;
1289	+	QueueToken(token,text);
1290	+	end;
1291	+
1292	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1293	+	begin
1294	+	ResetQueue;
1295	+	QueueToken(token);
1296	+	end;
1297	+
1298	+	procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1299	+	begin
1300	+	FQueueState := tsRelease;
1301	+	PopQueue(token);
1302	+	end;
1303	+
1304	+	procedure TSQLTokeniser.ReleaseQueue;
1305	+	begin
1306	+	FQueueState := tsRelease;
1307	+	end;
1308	+
1309	+	function TSQLTokeniser.GetQueuedText: AnsiString;
1310	+	var i: integer;
1311	+	begin
1312	+	Result := '';
1313	+	for i := FQFirst to FQLast do
1314	+	Result := Result + FTokenQueue[i].text;
1315	+	end;
1316	+
1317	+	procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1318	+	begin
1319	+	FString := text;
1320	+	end;
1321	+
1322	+	constructor TSQLTokeniser.Create;
1323	+	begin
1324	+	inherited Create;
1325	+	Reset;
1326	+	end;
1327	+
1328	+	destructor TSQLTokeniser.Destroy;
1329	+	begin
1330	+	Reset;
1331	+	inherited Destroy;
1332	+	end;
1333	+
1334	+	procedure TSQLTokeniser.Reset;
1335	+	begin
1336	+	FNextToken := sqltInit;
1337	+	FState := stDefault;
1338	+	FString := '';
1339	+	FEOF := false;
1340	+	ResetQueue;
1341	+	end;
1342	+
1343	+	function TSQLTokeniser.GetNextToken: TSQLTokens;
1344	+	begin
1345	+	if FQueueState = tsRelease then
1346	+	repeat
1347	+	PopQueue(Result);
1348	+	FEOF := Result = sqltEOF;
1349	+	if TokenFound(Result) then
1350	+	Exit;
1351	+	until FQueueState <> tsRelease;
1352	+
1353	+	Result := InternalGetNextToken;
1354	+	end;
1355	+
1356	+	{a simple lookahead one algorithm to extra the next symbol}
1357	+
1358	+	function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1359	+	var C: AnsiChar;
1360	+	begin
1361	+	Result := sqltEOF;
1362	+
1363	+	if FNextToken = sqltInit then
1364	+	GetNext;
1365	+
1366	+	repeat
1367	+	Result := FNextToken;
1368	+	C := FLastChar;
1369	+	GetNext;
1370	+
1371	+	if FSkipNext then
1372	+	begin
1373	+	FSkipNext := false;
1374	+	continue;
1375	+	end;
1376	+
1377	+	case FState of
1378	+	stInComment:
1379	+	begin
1380	+	if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1381	+	begin
1382	+	FState := stDefault;
1383	+	Result := sqltComment;
1384	+	GetNext;
1385	+	end
1386	+	else
1387	+	FString := FString + C;
1388	+	end;
1389	+
1390	+	stInCommentLine:
1391	+	begin
1392	+	case Result of
1393	+	sqltEOL:
1394	+	begin
1395	+	FState := stDefault;
1396	+	Result := sqltCommentLine;
1397	+	end;
1398	+
1399	+	sqltCR: {ignore};
1400	+
1401	+	else
1402	+	FString := FString + C;
1403	+	end;
1404	+	end;
1405	+
1406	+	stSingleQuoted:
1407	+	begin
1408	+	if (Result = sqltSingleQuotes) then
1409	+	begin
1410	+	if (FNextToken = sqltSingleQuotes) then
1411	+	begin
1412	+	FSkipNext := true;
1413	+	FString := FString + C;
1414	+	end
1415	+	else
1416	+	begin
1417	+	Result := sqltQuotedString;
1418	+	FState := stDefault;
1419	+	end;
1420	+	end
1421	+	else
1422	+	FString := FString + C;
1423	+	end;
1424	+
1425	+	stDoubleQuoted:
1426	+	begin
1427	+	if (Result = sqltDoubleQuotes) then
1428	+	begin
1429	+	if (FNextToken = sqltDoubleQuotes) then
1430	+	begin
1431	+	FSkipNext := true;
1432	+	FString := FString + C;
1433	+	end
1434	+	else
1435	+	begin
1436	+	Result := sqltIdentifierInDoubleQuotes;
1437	+	FState := stDefault;
1438	+	end;
1439	+	end
1440	+	else
1441	+	FString := FString + C;
1442	+	end;
1443	+
1444	+	stInIdentifier:
1445	+	begin
1446	+	FString := FString + C;
1447	+	Result := sqltIdentifier;
1448	+	if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1449	+	FState := stDefault
1450	+	end;
1451	+
1452	+	stInNumeric:
1453	+	begin
1454	+	FString := FString + C;
1455	+	if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1456	+	begin
1457	+	{malformed decimal}
1458	+	FState := stInIdentifier;
1459	+	Result := sqltIdentifier
1460	+	end
1461	+	else
1462	+	begin
1463	+	if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1464	+	FState := stDefault;
1465	+	Result := sqltNumberString;
1466	+	end;
1467	+	end;
1468	+
1469	+	else {stDefault}
1470	+	begin
1471	+	FString := C;
1472	+	case Result of
1473	+
1474	+	sqltPipe:
1475	+	if FNextToken = sqltPipe then
1476	+	begin
1477	+	Result := sqltConcatSymbol;
1478	+	FString := C + FLastChar;
1479	+	GetNext;
1480	+	end;
1481	+
1482	+	sqltForwardSlash:
1483	+	begin
1484	+	if FNextToken = sqltAsterisk then
1485	+	begin
1486	+	FString := '';
1487	+	GetNext;
1488	+	FState := stInComment;
1489	+	end
1490	+	end;
1491	+
1492	+	sqltMinus:
1493	+	begin
1494	+	if FNextToken = sqltMinus then
1495	+	begin
1496	+	FString := '';
1497	+	GetNext;
1498	+	FState := stInCommentLine;
1499	+	end;
1500	+	end;
1501	+
1502	+	sqltSingleQuotes:
1503	+	begin
1504	+	FString := '';
1505	+	FState := stSingleQuoted;
1506	+	end;
1507	+
1508	+	sqltDoubleQuotes:
1509	+	begin
1510	+	FString := '';
1511	+	FState := stDoubleQuoted;
1512	+	end;
1513	+
1514	+	sqltIdentifier:
1515	+	if FNextToken in [sqltIdentifier,sqltNumberString] then
1516	+	FState := stInIdentifier;
1517	+
1518	+	sqltNumberString:
1519	+	if FNextToken in [sqltNumberString,sqltPeriod] then
1520	+	FState := stInNumeric;
1521	+	end;
1522	+	end;
1523	+	end;
1524	+
1525	+	//    writeln(FString);
1526	+	FEOF := Result = sqltEOF;
1527	+	until TokenFound(Result) or EOF;
1528	+	end;
1529	+
1530		end.

Diff Legend

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