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 107 by tony, Thu Jan 18 14:37:40 2018 UTC vs.
Revision 270 by tony, Fri Jan 18 11:10:37 2019 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	>	sqltConcatSymbol,
284	>	sqltLT,
285	>	sqltGT,
286	>	sqltCR,
287	>	sqltEOL,
288	>	sqltEOF,
289	>	sqltInit
290	>	);
291	>
292	>	TSQLReservedWords = sqltAdd..sqltYear;
293
294		const
295		CRLF = #13 + #10;
#	Line 52 | Line 298 | const
298		TAB  = #9;
299		NULL_TERMINATOR = #0;
300
301	<	sqlReservedWords: array [0..197] of string = (
301	>	{$IFNDEF FPC}
302	>	LineEnding = CRLF;
303	>	{$ENDIF}
304	>
305	>	{SQL Reserved words in alphabetical order}
306	>
307	>	sqlReservedWords: array [TSQLReservedWords] of string = (
308		'ADD',
309		'ADMIN',
310		'ALL',
#	Line 144 | Line 396 | const
396		'INTO',
397		'IS',
398		'JOIN',
399	+	'KEY',
400		'LEADING',
401		'LEFT',
402		'LIKE',
#	Line 203 | Line 456 | const
456		'RIGHT',
457		'ROLLBACK',
458		'ROW',
206	–	'ROW_COUNT',
459		'ROWS',
460	+	'ROW_COUNT',
461		'SAVEPOINT',
462		'SCROLL',
463		'SECOND',
#	Line 216 | Line 469 | const
469		'SOME',
470		'SQLCODE',
471		'SQLSTATE',
219	–	'SQLSTATE',
472		'START',
473		'STDDEV_POP',
474		'STDDEV_SAMP',
#	Line 253 | Line 505 | const
505		'YEAR'
506		);
507
508	+	type
509	+	{The TSQLTokeniser class provides a common means to parse an SQL statement, or
510	+	even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
511	+	with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
512	+	is instantiated with a stream from which the SQL statements are read.
513	+
514	+	Successive calls to GetNextToken then return each SQL token. The TokenText contains
515	+	either the single character, the identifier or reserved word, the string or comment.}
516	+
517	+	{ TSQLTokeniser }
518	+
519	+	TSQLTokeniser = class
520	+	private
521	+	const
522	+	TokenQueueMaxSize = 64;
523	+	type
524	+	TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
525	+	stInIdentifier, stInNumeric);
526	+
527	+	TTokenQueueItem = record
528	+	token: TSQLTokens;
529	+	text: AnsiString;
530	+	end;
531	+	TTokenQueueState = (tsHold, tsRelease);
532	+
533	+	private
534	+	FLastChar: AnsiChar;
535	+	FState: TLexState;
536	+	FSkipNext: boolean;
537	+	function GetNext: TSQLTokens;
538	+
539	+	{The token Queue is available for use by descendents so that they can
540	+	hold back tokens in order to lookahead by token rather than just a single
541	+	character}
542	+
543	+	private
544	+	FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
545	+	FQueueState: TTokenQueueState;
546	+	FQFirst: integer;  {first and last pointers first=last => queue empty}
547	+	FQLast: integer;
548	+	FEOF: boolean;
549	+	procedure PopQueue(var token: TSQLTokens);
550	+	protected
551	+	FString: AnsiString;
552	+	FNextToken: TSQLTokens;
553	+	procedure Assign(source: TSQLTokeniser); virtual;
554	+	function GetChar: AnsiChar; virtual; abstract;
555	+	function TokenFound(var token: TSQLTokens): boolean; virtual;
556	+	function InternalGetNextToken: TSQLTokens; virtual;
557	+	procedure Reset; virtual;
558	+
559	+	{Token stack}
560	+	procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
561	+	procedure QueueToken(token: TSQLTokens); overload;
562	+	procedure ResetQueue; overload;
563	+	procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
564	+	procedure ResetQueue(token: TSQLTokens); overload;
565	+	procedure ReleaseQueue(var token: TSQLTokens); overload;
566	+	procedure ReleaseQueue; overload;
567	+	function GetQueuedText: AnsiString;
568	+	procedure SetTokenText(text: AnsiString);
569	+
570	+	public
571	+	const
572	+	DefaultTerminator = ';';
573	+	public
574	+	constructor Create;
575	+	destructor Destroy; override;
576	+	function GetNextToken: TSQLTokens;
577	+	property EOF: boolean read FEOF;
578	+	property TokenText: AnsiString read FString;
579	+	end;
580	+
581	+	{ TSQLwithNamedParamsTokeniser }
582	+
583	+	TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
584	+	private
585	+	type
586	+	TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
587	+	private
588	+	FState: TSQLState;
589	+	FNested: integer;
590	+	protected
591	+	procedure Assign(source: TSQLTokeniser); override;
592	+	procedure Reset; override;
593	+	function TokenFound(var token: TSQLTokens): boolean; override;
594	+	end;
595	+
596	+	{ TSQLParamProcessor }
597	+
598	+	TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
599	+	private
600	+	const
601	+	sIBXParam = 'IBXParam';  {do not localize}
602	+	private
603	+	FInString: AnsiString;
604	+	FIndex: integer;
605	+	function DoExecute(GenerateParamNames: boolean;
606	+	var slNames: TStrings): AnsiString;
607	+	protected
608	+	function GetChar: AnsiChar; override;
609	+	public
610	+	class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
611	+	var slNames: TStrings): AnsiString;
612	+	end;
613	+
614	+
615		function Max(n1, n2: Integer): Integer;
616		function Min(n1, n2: Integer): Integer;
617		function RandomString(iLength: Integer): AnsiString;
618		function RandomInteger(iLow, iHigh: Integer): Integer;
619		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;
620		function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
621	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
622	+	function IsReservedWord(w: AnsiString): boolean;
623		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
625		function Space2Underscore(s: AnsiString): AnsiString;
626		function SQLSafeString(const s: AnsiString): AnsiString;
627		function IsSQLIdentifier(Value: AnsiString): boolean;
628	+	function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
629	+	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
630	+	PortNo: AnsiString = ''): AnsiString;
631	+	function ParseConnectString(ConnectString: AnsiString;
632	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
633	+	var PortNo: AnsiString): boolean;
634	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
635
636		implementation
637
638	+	uses FBMessages
639	+
640	+	{$IFDEF HASREQEX}
641	+	,RegExpr
642	+	{$ENDIF};
643	+
644		function Max(n1, n2: Integer): Integer;
645		begin
646		if (n1 > n2) then
#	Line 311 | Line 682 | begin
682		end;
683		end;
684
685	<	function FormatIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
315	<	begin
316	<	Value := Trim(Value);
317	<	if Dialect = 1 then
318	<	Value := AnsiUpperCase(Value)
319	<	else
320	<	if (Value <> '') and (Value[1] = '"') then
321	<	Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
322	<	else
323	<	Value := AnsiUpperCase(Value);
324	<	Result := Value;
325	<	end;
685	>	{Extracts SQL Identifier typically from a  Dialect 3 encoding}
686
687	<	function FormatIdentifierValue(Dialect: Integer; Value: AnsiString): AnsiString;
687	>	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
688		begin
689		Value := Trim(Value);
690		if Dialect = 1 then
#	Line 343 | Line 703 | begin
703		Result := Value;
704		end;
705
706	<	function FormatIdentifierValueNC(Dialect: Integer; Value: AnsiString): AnsiString;
707	<	begin
348	<	Value := Trim(Value);
349	<	if Dialect = 1 then
350	<	Value := AnsiUpperCase(Value)
351	<	else
352	<	begin
353	<	if (Value <> '') and (Value[1] = '"') then
354	<	begin
355	<	Delete(Value, 1, 1);
356	<	Delete(Value, Length(Value), 1);
357	<	Value := AnsiUpperCase(StringReplace (Value, '""', '"', [rfReplaceAll]));
358	<	end
359	<	else
360	<	Value := AnsiUpperCase(Value);
361	<	end;
362	<	Result := Value;
363	<	end;
706	>	{Returns true if "w" is a Firebird SQL reserved word, and the
707	>	corresponding TSQLTokens value.}
708
709	<	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
709	>	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
710	>	var i: TSQLTokens;
711		begin
712	<	Value := Trim(Value);
713	<	if Dialect = 1 then
714	<	Value := AnsiUpperCase(Value)
715	<	else
716	<	begin
717	<	if (Value <> '') and (Value[1] = '"') then
718	<	begin
719	<	Delete(Value, 1, 1);
720	<	Delete(Value, Length(Value), 1);
721	<	Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
722	<	end
723	<	else
724	<	Value := AnsiUpperCase(Value);
380	<	end;
381	<	Result := Value;
712	>	Result := true;
713	>	w := AnsiUpperCase(Trim(w));
714	>	for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
715	>	begin
716	>	if w = sqlReservedWords[i] then
717	>	begin
718	>	token := i;
719	>	Exit;
720	>	end;
721	>	if w <  sqlReservedWords[i] then
722	>	break;
723	>	end;
724	>	Result := false;
725		end;
726
727	+	{Returns true if "w" is a Firebird SQL reserved word}
728	+
729		function IsReservedWord(w: AnsiString): boolean;
730	<	var i: integer;
730	>	var token: TSQLTokens;
731		begin
732	<	Result := true;
388	<	for i := 0 to Length(sqlReservedWords) - 1 do
389	<	if w = sqlReservedWords[i] then
390	<	Exit;
391	<	Result := false;
732	>	Result := FindReservedWord(w,token);
733		end;
734
735	+	{Format an SQL Identifier according to SQL Dialect}
736	+
737		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
738		begin
739		if Dialect = 1 then
740		Value := AnsiUpperCase(Trim(Value))
741		else
742	<	Value := '"' + Value + '"';
742	>	Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
743		Result := Value;
744		end;
745
746		const
747		ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
748
749	+	{Returns true if the value is a valid SQL Identifier - note lower case accepted}
750	+
751		function IsSQLIdentifier(Value: AnsiString): boolean;
752		var i: integer;
753		begin
#	Line 412 | Line 757 | begin
757		Result := true;
758		end;
759
760	+	{Extracts the Database Connect string from a Create Database Statement}
761	+
762	+	{$IFDEF HASREQEX}
763	+	function ExtractConnectString(const CreateSQL: AnsiString;
764	+	var ConnectString: AnsiString): boolean;
765	+	var RegexObj: TRegExpr;
766	+	begin
767	+	RegexObj := TRegExpr.Create;
768	+	try
769	+	{extact database file spec}
770	+	RegexObj.ModifierG := false; {turn off greedy matches}
771	+	RegexObj.ModifierI := true; {case insensitive match}
772	+	RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
773	+	Result := RegexObj.Exec(CreateSQL);
774	+	if Result then
775	+	ConnectString := RegexObj.Match[2];
776	+	finally
777	+	RegexObj.Free;
778	+	end;
779	+	end;
780	+
781	+	function ParseConnectString(ConnectString: AnsiString; var ServerName,
782	+	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
783	+	): boolean;
784	+
785	+	function GetProtocol(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	+	var RegexObj: TRegExpr;
805	+	begin
806	+	ServerName := '';
807	+	DatabaseName := ConnectString;
808	+	PortNo := '';
809	+	Protocol := unknownProtocol;
810	+	RegexObj := TRegExpr.Create;
811	+	try
812	+	{extact database file spec}
813	+	RegexObj.ModifierG := false; {turn off greedy matches}
814	+	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
815	+	Result := RegexObj.Exec(ConnectString);
816	+	if Result then
817	+	begin
818	+	{URL type connect string}
819	+	Protocol := GetProtocol(RegexObj.Match[1]);
820	+	ServerName := RegexObj.Match[2];
821	+	if RegexObj.MatchLen[3] > 0 then
822	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
823	+	DatabaseName := RegexObj.Match[4];
824	+	if ServerName = '' then
825	+	DatabaseName := '/' + DatabaseName;
826	+	end
827	+	else
828	+	begin
829	+	{URL type connect string - local loop}
830	+	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
831	+	Result := RegexObj.Exec(ConnectString);
832	+	if Result then
833	+	begin
834	+	Protocol := GetProtocol(RegexObj.Match[1]);
835	+	DatabaseName := RegexObj.Match[2];
836	+	end
837	+	else
838	+	begin
839	+	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
840	+	Result := RegexObj.Exec(ConnectString);
841	+	if Result then
842	+	Protocol := Local {Windows with leading drive ID}
843	+	else
844	+	begin
845	+	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
846	+	Result := RegexObj.Exec(ConnectString);
847	+	if Result then
848	+	begin
849	+	{Legacy TCP Format}
850	+	ServerName := RegexObj.Match[1];
851	+	if RegexObj.MatchLen[2] > 0 then
852	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
853	+	DatabaseName := RegexObj.Match[3];
854	+	Protocol := TCP;
855	+	end
856	+	else
857	+	begin
858	+	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
859	+	Result := RegexObj.Exec(ConnectString);
860	+	if Result then
861	+	begin
862	+	{Netbui}
863	+	ServerName := RegexObj.Match[1];
864	+	if RegexObj.MatchLen[2] > 0 then
865	+	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
866	+	DatabaseName := RegexObj.Match[3];
867	+	Protocol := NamedPipe
868	+	end
869	+	else
870	+	begin
871	+	Result := true;
872	+	Protocol := Local; {Assume local}
873	+	end;
874	+	end;
875	+	end;
876	+	end;
877	+	end;
878	+	finally
879	+	RegexObj.Free;
880	+	end;
881	+	end;
882	+
883	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
884	+	var ServerName,
885	+	DatabaseName: AnsiString;
886	+	PortNo: AnsiString;
887	+	begin
888	+	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
889	+	end;
890	+
891	+	{$ELSE}
892	+	{cruder version of above for Delphi. Older versions lack regular expression
893	+	handling.}
894	+	function ExtractConnectString(const CreateSQL: AnsiString;
895	+	var ConnectString: AnsiString): boolean;
896	+	var i: integer;
897	+	begin
898	+	Result := false;
899	+	i := Pos('''',CreateSQL);
900	+	if i > 0 then
901	+	begin
902	+	ConnectString := CreateSQL;
903	+	delete(ConnectString,1,i);
904	+	i := Pos('''',ConnectString);
905	+	if i > 0 then
906	+	begin
907	+	delete(ConnectString,i,Length(ConnectString)-i+1);
908	+	Result := true;
909	+	end;
910	+	end;
911	+	end;
912	+
913	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
914	+	begin
915	+	Result := unknownProtocol; {not implemented for Delphi}
916	+	end;
917	+
918	+	function ParseConnectString(ConnectString: AnsiString;
919	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
920	+	var PortNo: AnsiString): boolean;
921	+	begin
922	+	Result := false;
923	+	end;
924	+
925	+	{$ENDIF}
926	+
927	+	{Make a connect string in format appropriate protocol}
928	+
929	+	function MakeConnectString(ServerName, DatabaseName: AnsiString;
930	+	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
931	+
932	+	function FormatURL: AnsiString;
933	+	begin
934	+	if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
935	+	Result := DatabaseName
936	+	else
937	+	Result := ServerName + '/' + DatabaseName;
938	+	end;
939	+
940	+	begin
941	+	if PortNo <> '' then
942	+	case Protocol of
943	+	NamedPipe:
944	+	ServerName := ServerName + '@' + PortNo;
945	+	Local,
946	+	SPX,
947	+	xnet: {do nothing};
948	+	TCP:
949	+	ServerName := ServerName + '/' + PortNo;
950	+	else
951	+	ServerName := ServerName + ':' + PortNo;
952	+	end;
953	+
954	+	case Protocol of
955	+	TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
956	+	SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
957	+	NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
958	+	Local:      Result := DatabaseName; {do not localize}
959	+	inet:       Result := 'inet://' + FormatURL; {do not localize}
960	+	inet4:       Result := 'inet4://' + FormatURL; {do not localize}
961	+	inet6:       Result := 'inet6://' + FormatURL; {do not localize}
962	+	wnet:       Result := 'wnet://' + FormatURL; {do not localize}
963	+	xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
964	+	end;
965	+	end;
966	+
967	+	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
968	+
969		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
970		begin
971		if (Dialect = 3) and
972	<	(IsReservedWord(Value) or not IsSQLIdentifier(Value)) then
973	<	Result := '"' + Value + '"'
972	>	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
973	>	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
974		else
975		Result := Value
976		end;
977
978	+	{Replaces unknown characters in a string with underscores}
979	+
980		function Space2Underscore(s: AnsiString): AnsiString;
981		var
982		k: integer;
983		begin
984		Result := s;
985		for k := 1 to Length(s) do
986	<	if not (Result[k] in ['0'..'9','A'..'Z','_','$'])  then
986	>	if not (Result[k] in ValidSQLIdentifierChars)  then
987		Result[k] := '_';
988		end;
989
990	+	{Reformats an SQL string with single quotes duplicated.}
991	+
992		function SQLSafeString(const s: AnsiString): AnsiString;
993		begin
994		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
995		end;
996
997	+	{ TSQLParamProcessor }
998	+
999	+	function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1000	+	var slNames: TStrings): AnsiString;
1001	+	var token: TSQLTokens;
1002	+	iParamSuffix: Integer;
1003	+	begin
1004	+	Result := '';
1005	+	iParamSuffix := 0;
1006	+
1007	+	while not EOF do
1008	+	begin
1009	+	token := GetNextToken;
1010	+	case token of
1011	+	sqltParam,
1012	+	sqltQuotedParam:
1013	+	begin
1014	+	Result := Result + '?';
1015	+	slNames.Add(TokenText);
1016	+	end;
1017	+
1018	+	sqltPlaceHolder:
1019	+	if GenerateParamNames then
1020	+	begin
1021	+	Inc(iParamSuffix);
1022	+	slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1023	+	//add pointer to self to mark entry
1024	+	Result := Result + '?';
1025	+	end
1026	+	else
1027	+	IBError(ibxeSQLParseError, [SParamNameExpected]);
1028	+
1029	+	sqltQuotedString:
1030	+	Result := Result + '''' + SQLSafeString(TokenText) + '''';
1031	+
1032	+	sqltIdentifierInDoubleQuotes:
1033	+	Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1034	+
1035	+	sqltComment:
1036	+	Result := Result + '/*' + TokenText + '*/';
1037	+
1038	+	sqltCommentLine:
1039	+	Result := Result + '//' + TokenText + LineEnding;
1040	+
1041	+	sqltEOL:
1042	+	Result := Result + LineEnding;
1043	+
1044	+	else
1045	+	Result := Result + TokenText;
1046	+	end;
1047	+	end;
1048	+	end;
1049	+
1050	+	function TSQLParamProcessor.GetChar: AnsiChar;
1051	+	begin
1052	+	if FIndex <= Length(FInString) then
1053	+	begin
1054	+	Result := FInString[FIndex];
1055	+	Inc(FIndex);
1056	+	end
1057	+	else
1058	+	Result := #0;
1059	+	end;
1060	+
1061	+	class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1062	+	GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1063	+	begin
1064	+	with self.Create do
1065	+	try
1066	+	FInString := sSQL;
1067	+	FIndex := 1;
1068	+	Result := DoExecute(GenerateParamNames,slNames);
1069	+	finally
1070	+	Free;
1071	+	end;
1072	+	end;
1073	+
1074	+	{ TSQLwithNamedParamsTokeniser }
1075	+
1076	+	procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1077	+	begin
1078	+	inherited Assign(source);
1079	+	if source is TSQLwithNamedParamsTokeniser then
1080	+	begin
1081	+	FState := TSQLwithNamedParamsTokeniser(source).FState;
1082	+	FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1083	+	end;
1084	+	end;
1085	+
1086	+	procedure TSQLwithNamedParamsTokeniser.Reset;
1087	+	begin
1088	+	inherited Reset;
1089	+	FState := stInit;
1090	+	FNested := 0;
1091	+	end;
1092	+
1093	+	function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1094	+	): boolean;
1095	+	begin
1096	+	Result := inherited TokenFound(token);
1097	+	if not Result then Exit;
1098	+
1099	+	case FState of
1100	+	stInit:
1101	+	begin
1102	+	case token of
1103	+	sqltColon:
1104	+	begin
1105	+	FState := stInParam;
1106	+	ResetQueue(token);
1107	+	end;
1108	+
1109	+	sqltBegin:
1110	+	begin
1111	+	FState := stInBlock;
1112	+	FNested := 1;
1113	+	end;
1114	+
1115	+	sqltOpenSquareBracket:
1116	+	FState := stInArrayDim;
1117	+
1118	+	end;
1119	+	end;
1120	+
1121	+	stInParam:
1122	+	begin
1123	+	case token of
1124	+	sqltIdentifier:
1125	+	token := sqltParam;
1126	+
1127	+	sqltIdentifierInDoubleQuotes:
1128	+	token := sqltQuotedParam;
1129	+
1130	+	else
1131	+	begin
1132	+	QueueToken(token);
1133	+	ReleaseQueue(token);
1134	+	end;
1135	+	end;
1136	+	FState := stInit;
1137	+	end;
1138	+
1139	+	stInBlock:
1140	+	begin
1141	+	case token of
1142	+	sqltBegin:
1143	+	Inc(FNested);
1144	+
1145	+	sqltEnd:
1146	+	begin
1147	+	Dec(FNested);
1148	+	if FNested = 0 then
1149	+	FState := stInit;
1150	+	end;
1151	+	end;
1152	+	end;
1153	+
1154	+	stInArrayDim:
1155	+	begin
1156	+	if token = sqltCloseSquareBracket then
1157	+	FState := stInit;
1158	+	end;
1159	+	end;
1160	+
1161	+	Result := (FState <> stInParam);
1162	+	end;
1163	+
1164	+	{ TSQLTokeniser }
1165	+
1166	+	function TSQLTokeniser.GetNext: TSQLTokens;
1167	+	var C: AnsiChar;
1168	+	begin
1169	+	if EOF then
1170	+	Result := sqltEOF
1171	+	else
1172	+	begin
1173	+	C := GetChar;
1174	+	case C of
1175	+	#0:
1176	+	Result := sqltEOF;
1177	+	' ',TAB:
1178	+	Result := sqltSpace;
1179	+	'0'..'9':
1180	+	Result := sqltNumberString;
1181	+	';':
1182	+	Result := sqltSemiColon;
1183	+	'?':
1184	+	Result := sqltPlaceholder;
1185	+	'|':
1186	+	Result := sqltPipe;
1187	+	'"':
1188	+	Result := sqltDoubleQuotes;
1189	+	'''':
1190	+	Result := sqltSingleQuotes;
1191	+	'/':
1192	+	Result := sqltForwardSlash;
1193	+	'\':
1194	+	Result := sqltBackslash;
1195	+	'*':
1196	+	Result := sqltAsterisk;
1197	+	'(':
1198	+	Result := sqltOpenBracket;
1199	+	')':
1200	+	Result := sqltCloseBracket;
1201	+	':':
1202	+	Result := sqltColon;
1203	+	',':
1204	+	Result := sqltComma;
1205	+	'.':
1206	+	Result := sqltPeriod;
1207	+	'=':
1208	+	Result := sqltEquals;
1209	+	'[':
1210	+	Result := sqltOpenSquareBracket;
1211	+	']':
1212	+	Result := sqltCloseSquareBracket;
1213	+	'<':
1214	+	Result := sqltLT;
1215	+	'>':
1216	+	Result := sqltGT;
1217	+	CR:
1218	+	Result := sqltCR;
1219	+	LF:
1220	+	Result := sqltEOL;
1221	+	else
1222	+	if C in ValidSQLIdentifierChars then
1223	+	Result := sqltIdentifier
1224	+	else
1225	+	Result := sqltOtherCharacter;
1226	+	end;
1227	+	FLastChar := C
1228	+	end;
1229	+	FNextToken := Result;
1230	+	end;
1231	+
1232	+	procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1233	+	begin
1234	+	if FQFirst = FQLast then
1235	+	IBError(ibxeTokenQueueUnderflow,[]);
1236	+	token := FTokenQueue[FQFirst].token;
1237	+	FString := FTokenQueue[FQFirst].text;
1238	+	Inc(FQFirst);
1239	+	if FQFirst = FQLast then
1240	+	FQueueState := tsHold;
1241	+	end;
1242	+
1243	+	procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1244	+	begin
1245	+	FString := source.FString;
1246	+	FNextToken := source.FNextToken;
1247	+	FTokenQueue := source.FTokenQueue;
1248	+	FQueueState := source.FQueueState;
1249	+	FQFirst := source.FQFirst;
1250	+	FQLast := source.FQLast;
1251	+	end;
1252	+
1253	+	function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1254	+	begin
1255	+	Result := (FState = stDefault);
1256	+	if Result and (token = sqltIdentifier)  then
1257	+	FindReservedWord(FString,token);
1258	+	end;
1259	+
1260	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1261	+	begin
1262	+	if FQLast > TokenQueueMaxSize then
1263	+	IBError(ibxeTokenQueueOverflow,[]);
1264	+	FTokenQueue[FQLast].token := token;
1265	+	FTokenQueue[FQLast].text := text;
1266	+	Inc(FQLast);
1267	+	end;
1268	+
1269	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1270	+	begin
1271	+	QueueToken(token,TokenText);
1272	+	end;
1273	+
1274	+	procedure TSQLTokeniser.ResetQueue;
1275	+	begin
1276	+	FQFirst := 0;
1277	+	FQLast := 0;
1278	+	FQueueState := tsHold;
1279	+	end;
1280	+
1281	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1282	+	begin
1283	+	ResetQueue;
1284	+	QueueToken(token,text);
1285	+	end;
1286	+
1287	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1288	+	begin
1289	+	ResetQueue;
1290	+	QueueToken(token);
1291	+	end;
1292	+
1293	+	procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1294	+	begin
1295	+	FQueueState := tsRelease;
1296	+	PopQueue(token);
1297	+	end;
1298	+
1299	+	procedure TSQLTokeniser.ReleaseQueue;
1300	+	begin
1301	+	FQueueState := tsRelease;
1302	+	end;
1303	+
1304	+	function TSQLTokeniser.GetQueuedText: AnsiString;
1305	+	var i: integer;
1306	+	begin
1307	+	Result := '';
1308	+	for i := FQFirst to FQLast do
1309	+	Result := Result + FTokenQueue[i].text;
1310	+	end;
1311	+
1312	+	procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1313	+	begin
1314	+	FString := text;
1315	+	end;
1316	+
1317	+	constructor TSQLTokeniser.Create;
1318	+	begin
1319	+	inherited Create;
1320	+	Reset;
1321	+	end;
1322	+
1323	+	destructor TSQLTokeniser.Destroy;
1324	+	begin
1325	+	Reset;
1326	+	inherited Destroy;
1327	+	end;
1328	+
1329	+	procedure TSQLTokeniser.Reset;
1330	+	begin
1331	+	FNextToken := sqltInit;
1332	+	FState := stDefault;
1333	+	FString := '';
1334	+	FEOF := false;
1335	+	ResetQueue;
1336	+	end;
1337	+
1338	+	function TSQLTokeniser.GetNextToken: TSQLTokens;
1339	+	begin
1340	+	if FQueueState = tsRelease then
1341	+	repeat
1342	+	PopQueue(Result);
1343	+	FEOF := Result = sqltEOF;
1344	+	if TokenFound(Result) then
1345	+	Exit;
1346	+	until FQueueState <> tsRelease;
1347	+
1348	+	Result := InternalGetNextToken;
1349	+	end;
1350	+
1351	+	{a simple lookahead one algorithm to extra the next symbol}
1352	+
1353	+	function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1354	+	var C: AnsiChar;
1355	+	begin
1356	+	Result := sqltEOF;
1357	+
1358	+	if FNextToken = sqltInit then
1359	+	GetNext;
1360	+
1361	+	repeat
1362	+	Result := FNextToken;
1363	+	C := FLastChar;
1364	+	GetNext;
1365	+
1366	+	if FSkipNext then
1367	+	begin
1368	+	FSkipNext := false;
1369	+	continue;
1370	+	end;
1371	+
1372	+	case FState of
1373	+	stInComment:
1374	+	begin
1375	+	if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1376	+	begin
1377	+	FState := stDefault;
1378	+	Result := sqltComment;
1379	+	GetNext;
1380	+	end
1381	+	else
1382	+	FString := FString + C;
1383	+	end;
1384	+
1385	+	stInCommentLine:
1386	+	begin
1387	+	case Result of
1388	+	sqltEOL:
1389	+	begin
1390	+	FState := stDefault;
1391	+	Result := sqltCommentLine;
1392	+	end;
1393	+
1394	+	sqltCR: {ignore};
1395	+
1396	+	else
1397	+	FString := FString + C;
1398	+	end;
1399	+	end;
1400	+
1401	+	stSingleQuoted:
1402	+	begin
1403	+	if (Result = sqltSingleQuotes) then
1404	+	begin
1405	+	if (FNextToken = sqltSingleQuotes) then
1406	+	begin
1407	+	FSkipNext := true;
1408	+	FString := FString + C;
1409	+	end
1410	+	else
1411	+	begin
1412	+	Result := sqltQuotedString;
1413	+	FState := stDefault;
1414	+	end;
1415	+	end
1416	+	else
1417	+	FString := FString + C;
1418	+	end;
1419	+
1420	+	stDoubleQuoted:
1421	+	begin
1422	+	if (Result = sqltDoubleQuotes) then
1423	+	begin
1424	+	if (FNextToken = sqltDoubleQuotes) then
1425	+	begin
1426	+	FSkipNext := true;
1427	+	FString := FString + C;
1428	+	end
1429	+	else
1430	+	begin
1431	+	Result := sqltIdentifierInDoubleQuotes;
1432	+	FState := stDefault;
1433	+	end;
1434	+	end
1435	+	else
1436	+	FString := FString + C;
1437	+	end;
1438	+
1439	+	stInIdentifier:
1440	+	begin
1441	+	FString := FString + C;
1442	+	Result := sqltIdentifier;
1443	+	if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1444	+	FState := stDefault
1445	+	end;
1446	+
1447	+	stInNumeric:
1448	+	begin
1449	+	FString := FString + C;
1450	+	if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1451	+	begin
1452	+	{malformed decimal}
1453	+	FState := stInIdentifier;
1454	+	Result := sqltIdentifier
1455	+	end
1456	+	else
1457	+	begin
1458	+	if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1459	+	FState := stDefault;
1460	+	Result := sqltNumberString;
1461	+	end;
1462	+	end;
1463	+
1464	+	else {stDefault}
1465	+	begin
1466	+	FString := C;
1467	+	case Result of
1468	+
1469	+	sqltPipe:
1470	+	if FNextToken = sqltPipe then
1471	+	begin
1472	+	Result := sqltConcatSymbol;
1473	+	FString := C + FLastChar;
1474	+	GetNext;
1475	+	end;
1476	+
1477	+	sqltForwardSlash:
1478	+	begin
1479	+	if FNextToken = sqltAsterisk then
1480	+	begin
1481	+	FString := '';
1482	+	GetNext;
1483	+	FState := stInComment;
1484	+	end
1485	+	else
1486	+	if FNextToken = sqltForwardSlash then
1487	+	begin
1488	+	FString := '';
1489	+	GetNext;
1490	+	FState := stInCommentLine;
1491	+	end;
1492	+	end;
1493	+
1494	+	sqltSingleQuotes:
1495	+	begin
1496	+	FString := '';
1497	+	FState := stSingleQuoted;
1498	+	end;
1499	+
1500	+	sqltDoubleQuotes:
1501	+	begin
1502	+	FString := '';
1503	+	FState := stDoubleQuoted;
1504	+	end;
1505	+
1506	+	sqltIdentifier:
1507	+	if FNextToken in [sqltIdentifier,sqltNumberString] then
1508	+	FState := stInIdentifier;
1509	+
1510	+	sqltNumberString:
1511	+	if FNextToken in [sqltNumberString,sqltPeriod] then
1512	+	FState := stInNumeric;
1513	+	end;
1514	+	end;
1515	+	end;
1516	+
1517	+	//    writeln(FString);
1518	+	FEOF := Result = sqltEOF;
1519	+	until TokenFound(Result) or EOF;
1520	+	end;
1521	+
1522		end.

Diff Legend

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