ViewVC Help

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

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

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 119 by tony, Mon Jan 22 13:58:18 2018 UTC vs.
Revision 265 by tony, Sat Dec 8 11:22:27 2018 UTC

#	Line 34 | Line 34
34		unit IBUtils;
35		{$IFDEF MSWINDOWS}
36		{$DEFINE WINDOWS}
37	–	{$IF defined(CompilerVersion) and (CompilerVersion >= 28)}
38	–	{Delphi XE7 onwards}}
39	–	{$define HASREQEX}
40	–	{$IFEND}
37		{$ENDIF}
38
39		{$IFDEF FPC}
#	Line 49 | Line 45 | unit IBUtils;
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	>	sqltComma,
262	>	sqltPeriod,
263	>	sqltEquals,
264	>	sqltOtherCharacter,
265	>	sqltIdentifier,
266	>	sqltIdentifierInDoubleQuotes,
267	>	sqltNumberString,
268	>	sqltString,
269	>	sqltParam,
270	>	sqltQuotedParam,
271	>	sqltColon,
272	>	sqltComment,
273	>	sqltCommentLine,
274	>	sqltQuotedString,
275	>	sqltAsterisk,
276	>	sqltForwardSlash,
277	>	sqltOpenSquareBracket,
278	>	sqltCloseSquareBracket,
279	>	sqltOpenBracket,
280	>	sqltCloseBracket,
281	>	sqltPipe,
282	>	sqltConcatSymbol,
283	>	sqltLT,
284	>	sqltGT,
285	>	sqltCR,
286	>	sqltEOL,
287	>	sqltEOF,
288	>	sqltInit
289	>	);
290	>
291	>	TSQLReservedWords = sqltAdd..sqltYear;
292
293		const
294		CRLF = #13 + #10;
#	Line 58 | Line 297 | const
297		TAB  = #9;
298		NULL_TERMINATOR = #0;
299
300	<	sqlReservedWords: array [0..197] of string = (
300	>	{$IFNDEF FPC}
301	>	LineEnding = CRLF;
302	>	{$ENDIF}
303	>
304	>	{SQL Reserved words in alphabetical order}
305	>
306	>	sqlReservedWords: array [TSQLReservedWords] of string = (
307		'ADD',
308		'ADMIN',
309		'ALL',
#	Line 150 | Line 395 | const
395		'INTO',
396		'IS',
397		'JOIN',
398	+	'KEY',
399		'LEADING',
400		'LEFT',
401		'LIKE',
#	Line 209 | Line 455 | const
455		'RIGHT',
456		'ROLLBACK',
457		'ROW',
212	–	'ROW_COUNT',
458		'ROWS',
459	+	'ROW_COUNT',
460		'SAVEPOINT',
461		'SCROLL',
462		'SECOND',
#	Line 222 | Line 468 | const
468		'SOME',
469		'SQLCODE',
470		'SQLSTATE',
225	–	'SQLSTATE',
471		'START',
472		'STDDEV_POP',
473		'STDDEV_SAMP',
#	Line 259 | Line 504 | const
504		'YEAR'
505		);
506
507	+	type
508	+	{The TSQLTokeniser class provides a common means to parse an SQL statement, or
509	+	even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
510	+	with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
511	+	is instantiated with a stream from which the SQL statements are read.
512	+
513	+	Successive calls to GetNextToken then return each SQL token. The TokenText contains
514	+	either the single character, the identifier or reserved word, the string or comment.}
515	+
516	+	{ TSQLTokeniser }
517	+
518	+	TSQLTokeniser = class
519	+	private
520	+	const
521	+	TokenQueueMaxSize = 64;
522	+	type
523	+	TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
524	+	stInIdentifier, stInNumeric);
525	+
526	+	TTokenQueueItem = record
527	+	token: TSQLTokens;
528	+	text: AnsiString;
529	+	end;
530	+	TTokenQueueState = (tsHold, tsRelease);
531	+
532	+	private
533	+	FLastChar: AnsiChar;
534	+	FState: TLexState;
535	+	FSkipNext: boolean;
536	+	function GetNext: TSQLTokens;
537	+
538	+	{The token Queue is available for use by descendents so that they can
539	+	hold back tokens in order to lookahead by token rather than just a single
540	+	character}
541	+
542	+	private
543	+	FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
544	+	FQueueState: TTokenQueueState;
545	+	FQFirst: integer;  {first and last pointers first=last => queue empty}
546	+	FQLast: integer;
547	+	FEOF: boolean;
548	+	procedure PopQueue(var token: TSQLTokens);
549	+	protected
550	+	FString: AnsiString;
551	+	FNextToken: TSQLTokens;
552	+	procedure Assign(source: TSQLTokeniser); virtual;
553	+	function GetChar: AnsiChar; virtual; abstract;
554	+	function TokenFound(var token: TSQLTokens): boolean; virtual;
555	+	function InternalGetNextToken: TSQLTokens; virtual;
556	+	procedure Reset; virtual;
557	+
558	+	{Token stack}
559	+	procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
560	+	procedure QueueToken(token: TSQLTokens); overload;
561	+	procedure ResetQueue; overload;
562	+	procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
563	+	procedure ResetQueue(token: TSQLTokens); overload;
564	+	procedure ReleaseQueue(var token: TSQLTokens); overload;
565	+	procedure ReleaseQueue; overload;
566	+	function GetQueuedText: AnsiString;
567	+	procedure SetTokenText(text: AnsiString);
568	+
569	+	public
570	+	const
571	+	DefaultTerminator = ';';
572	+	public
573	+	constructor Create;
574	+	destructor Destroy; override;
575	+	function GetNextToken: TSQLTokens;
576	+	property EOF: boolean read FEOF;
577	+	property TokenText: AnsiString read FString;
578	+	end;
579	+
580	+	{ TSQLwithNamedParamsTokeniser }
581	+
582	+	TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
583	+	private
584	+	type
585	+	TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
586	+	private
587	+	FState: TSQLState;
588	+	FNested: integer;
589	+	protected
590	+	procedure Assign(source: TSQLTokeniser); override;
591	+	procedure Reset; override;
592	+	function TokenFound(var token: TSQLTokens): boolean; override;
593	+	end;
594	+
595		function Max(n1, n2: Integer): Integer;
596		function Min(n1, n2: Integer): Integer;
597		function RandomString(iLength: Integer): AnsiString;
598		function RandomInteger(iLow, iHigh: Integer): Integer;
599		function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
600		function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
601	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
602	+	function IsReservedWord(w: AnsiString): boolean;
603		function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
604		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
605		function Space2Underscore(s: AnsiString): AnsiString;
606		function SQLSafeString(const s: AnsiString): AnsiString;
607		function IsSQLIdentifier(Value: AnsiString): boolean;
608		function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
609	+	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
610	+	PortNo: AnsiString = ''): AnsiString;
611	+	function ParseConnectString(ConnectString: AnsiString;
612	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
613	+	var PortNo: AnsiString): boolean;
614	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
615
616		implementation
617
618	+	uses FBMessages
619	+
620		{$IFDEF HASREQEX}
621	<	uses RegExpr;
622	<	{$ENDIF}
621	>	,RegExpr
622	>	{$ENDIF};
623
624		function Max(n1, n2: Integer): Integer;
625		begin
#	Line 340 | Line 683 | begin
683		Result := Value;
684		end;
685
686	+	{Returns true if "w" is a Firebird SQL reserved word, and the
687	+	corresponding TSQLTokens value.}
688	+
689	+	function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
690	+	var i: TSQLTokens;
691	+	begin
692	+	Result := true;
693	+	w := AnsiUpperCase(Trim(w));
694	+	for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
695	+	begin
696	+	if w = sqlReservedWords[i] then
697	+	begin
698	+	token := i;
699	+	Exit;
700	+	end;
701	+	if w <  sqlReservedWords[i] then
702	+	break;
703	+	end;
704	+	Result := false;
705	+	end;
706	+
707		{Returns true if "w" is a Firebird SQL reserved word}
708
709		function IsReservedWord(w: AnsiString): boolean;
710	<	var i: integer;
710	>	var token: TSQLTokens;
711		begin
712	<	Result := true;
349	<	for i := 0 to Length(sqlReservedWords) - 1 do
350	<	if w = sqlReservedWords[i] then
351	<	Exit;
352	<	Result := false;
712	>	Result := FindReservedWord(w,token);
713		end;
714
715		{Format an SQL Identifier according to SQL Dialect}
#	Line 392 | Line 752 | begin
752		RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
753		Result := RegexObj.Exec(CreateSQL);
754		if Result then
755	<	ConnectString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
755	>	ConnectString := RegexObj.Match[2];
756	>	finally
757	>	RegexObj.Free;
758	>	end;
759	>	end;
760	>
761	>	function ParseConnectString(ConnectString: AnsiString; var ServerName,
762	>	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
763	>	): boolean;
764	>
765	>	function GetProtocol(scheme: AnsiString): TProtocolAll;
766	>	begin
767	>	scheme := AnsiUpperCase(scheme);
768	>	if scheme = 'INET' then
769	>	Result := inet
770	>	else
771	>	if scheme = 'INET4' then
772	>	Result := inet4
773	>	else
774	>	if scheme = 'INET6' then
775	>	Result := inet6
776	>	else
777	>	if scheme = 'XNET' then
778	>	Result := xnet
779	>	else
780	>	if scheme = 'WNET' then
781	>	Result := wnet
782	>	end;
783	>
784	>	var RegexObj: TRegExpr;
785	>	begin
786	>	ServerName := '';
787	>	DatabaseName := ConnectString;
788	>	PortNo := '';
789	>	Protocol := unknownProtocol;
790	>	RegexObj := TRegExpr.Create;
791	>	try
792	>	{extact database file spec}
793	>	RegexObj.ModifierG := false; {turn off greedy matches}
794	>	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
795	>	Result := RegexObj.Exec(ConnectString);
796	>	if Result then
797	>	begin
798	>	{URL type connect string}
799	>	Protocol := GetProtocol(RegexObj.Match[1]);
800	>	ServerName := RegexObj.Match[2];
801	>	if RegexObj.MatchLen[3] > 0 then
802	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
803	>	DatabaseName := RegexObj.Match[4];
804	>	if ServerName = '' then
805	>	DatabaseName := '/' + DatabaseName;
806	>	end
807	>	else
808	>	begin
809	>	{URL type connect string - local loop}
810	>	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
811	>	Result := RegexObj.Exec(ConnectString);
812	>	if Result then
813	>	begin
814	>	Protocol := GetProtocol(RegexObj.Match[1]);
815	>	DatabaseName := RegexObj.Match[2];
816	>	end
817	>	else
818	>	begin
819	>	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
820	>	Result := RegexObj.Exec(ConnectString);
821	>	if Result then
822	>	Protocol := Local {Windows with leading drive ID}
823	>	else
824	>	begin
825	>	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
826	>	Result := RegexObj.Exec(ConnectString);
827	>	if Result then
828	>	begin
829	>	{Legacy TCP Format}
830	>	ServerName := RegexObj.Match[1];
831	>	if RegexObj.MatchLen[2] > 0 then
832	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
833	>	DatabaseName := RegexObj.Match[3];
834	>	Protocol := TCP;
835	>	end
836	>	else
837	>	begin
838	>	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
839	>	Result := RegexObj.Exec(ConnectString);
840	>	if Result then
841	>	begin
842	>	{Netbui}
843	>	ServerName := RegexObj.Match[1];
844	>	if RegexObj.MatchLen[2] > 0 then
845	>	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
846	>	DatabaseName := RegexObj.Match[3];
847	>	Protocol := NamedPipe
848	>	end
849	>	else
850	>	begin
851	>	Result := true;
852	>	Protocol := Local; {Assume local}
853	>	end;
854	>	end;
855	>	end;
856	>	end;
857	>	end;
858		finally
859		RegexObj.Free;
860		end;
861		end;
862	+
863	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
864	+	var ServerName,
865	+	DatabaseName: AnsiString;
866	+	PortNo: AnsiString;
867	+	begin
868	+	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
869	+	end;
870	+
871		{$ELSE}
872	<	{cruder version of above for old versions of Delphi}
872	>	{cruder version of above for Delphi. Older versions lack regular expression
873	>	handling.}
874		function ExtractConnectString(const CreateSQL: AnsiString;
875		var ConnectString: AnsiString): boolean;
876		var i: integer;
#	Line 417 | Line 889 | begin
889		end;
890		end;
891		end;
892	+
893	+	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
894	+	begin
895	+	Result := unknownProtocol; {not implemented for Delphi}
896	+	end;
897	+
898	+	function ParseConnectString(ConnectString: AnsiString;
899	+	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
900	+	var PortNo: AnsiString): boolean;
901	+	begin
902	+	Result := false;
903	+	end;
904	+
905		{$ENDIF}
906
907	+	{Make a connect string in format appropriate protocol}
908	+
909	+	function MakeConnectString(ServerName, DatabaseName: AnsiString;
910	+	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
911	+
912	+	function FormatURL: AnsiString;
913	+	begin
914	+	if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
915	+	Result := DatabaseName
916	+	else
917	+	Result := ServerName + '/' + DatabaseName;
918	+	end;
919	+
920	+	begin
921	+	if PortNo <> '' then
922	+	case Protocol of
923	+	NamedPipe:
924	+	ServerName := ServerName + '@' + PortNo;
925	+	Local,
926	+	SPX,
927	+	xnet: {do nothing};
928	+	TCP:
929	+	ServerName := ServerName + '/' + PortNo;
930	+	else
931	+	ServerName := ServerName + ':' + PortNo;
932	+	end;
933	+
934	+	case Protocol of
935	+	TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
936	+	SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
937	+	NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
938	+	Local:      Result := DatabaseName; {do not localize}
939	+	inet:       Result := 'inet://' + FormatURL; {do not localize}
940	+	inet4:       Result := 'inet4://' + FormatURL; {do not localize}
941	+	inet6:       Result := 'inet6://' + FormatURL; {do not localize}
942	+	wnet:       Result := 'wnet://' + FormatURL; {do not localize}
943	+	xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
944	+	end;
945	+	end;
946	+
947		{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
948
949		function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
#	Line 449 | Line 974 | begin
974		Result := StringReplace(s,'''','''''',[rfReplaceAll]);
975		end;
976
977	+	{ TSQLwithNamedParamsTokeniser }
978	+
979	+	procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
980	+	begin
981	+	inherited Assign(source);
982	+	if source is TSQLwithNamedParamsTokeniser then
983	+	begin
984	+	FState := TSQLwithNamedParamsTokeniser(source).FState;
985	+	FNested := TSQLwithNamedParamsTokeniser(source).FNested;
986	+	end;
987	+	end;
988	+
989	+	procedure TSQLwithNamedParamsTokeniser.Reset;
990	+	begin
991	+	inherited Reset;
992	+	FState := stInit;
993	+	FNested := 0;
994	+	end;
995	+
996	+	function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
997	+	): boolean;
998	+	begin
999	+	Result := inherited TokenFound(token);
1000	+	if not Result then Exit;
1001	+
1002	+	case FState of
1003	+	stInit:
1004	+	begin
1005	+	case token of
1006	+	sqltColon:
1007	+	begin
1008	+	FState := stInParam;
1009	+	ResetQueue(token);
1010	+	end;
1011	+
1012	+	sqltBegin:
1013	+	begin
1014	+	FState := stInBlock;
1015	+	FNested := 1;
1016	+	end;
1017	+
1018	+	sqltOpenSquareBracket:
1019	+	FState := stInArrayDim;
1020	+
1021	+	end;
1022	+	end;
1023	+
1024	+	stInParam:
1025	+	begin
1026	+	case token of
1027	+	sqltIdentifier:
1028	+	token := sqltParam;
1029	+
1030	+	sqltIdentifierInDoubleQuotes:
1031	+	token := sqltQuotedParam;
1032	+
1033	+	else
1034	+	begin
1035	+	QueueToken(token);
1036	+	ReleaseQueue(token);
1037	+	end;
1038	+	end;
1039	+	FState := stInit;
1040	+	end;
1041	+
1042	+	stInBlock:
1043	+	begin
1044	+	case token of
1045	+	sqltBegin:
1046	+	Inc(FNested);
1047	+
1048	+	sqltEnd:
1049	+	begin
1050	+	Dec(FNested);
1051	+	if FNested = 0 then
1052	+	FState := stInit;
1053	+	end;
1054	+	end;
1055	+	end;
1056	+
1057	+	stInArrayDim:
1058	+	begin
1059	+	if token = sqltCloseSquareBracket then
1060	+	FState := stInit;
1061	+	end;
1062	+	end;
1063	+
1064	+	Result := (FState <> stInParam);
1065	+	end;
1066	+
1067	+	{ TSQLTokeniser }
1068	+
1069	+	function TSQLTokeniser.GetNext: TSQLTokens;
1070	+	var C: AnsiChar;
1071	+	begin
1072	+	if EOF then
1073	+	Result := sqltEOF
1074	+	else
1075	+	begin
1076	+	C := GetChar;
1077	+	case C of
1078	+	#0:
1079	+	Result := sqltEOF;
1080	+	' ',TAB:
1081	+	Result := sqltSpace;
1082	+	'0'..'9':
1083	+	Result := sqltNumberString;
1084	+	';':
1085	+	Result := sqltSemiColon;
1086	+	'?':
1087	+	Result := sqltPlaceholder;
1088	+	'|':
1089	+	Result := sqltPipe;
1090	+	'"':
1091	+	Result := sqltDoubleQuotes;
1092	+	'''':
1093	+	Result := sqltSingleQuotes;
1094	+	'/':
1095	+	Result := sqltForwardSlash;
1096	+	'*':
1097	+	Result := sqltAsterisk;
1098	+	'(':
1099	+	Result := sqltOpenBracket;
1100	+	')':
1101	+	Result := sqltCloseBracket;
1102	+	':':
1103	+	Result := sqltColon;
1104	+	',':
1105	+	Result := sqltComma;
1106	+	'.':
1107	+	Result := sqltPeriod;
1108	+	'=':
1109	+	Result := sqltEquals;
1110	+	'[':
1111	+	Result := sqltOpenSquareBracket;
1112	+	']':
1113	+	Result := sqltCloseSquareBracket;
1114	+	'<':
1115	+	Result := sqltLT;
1116	+	'>':
1117	+	Result := sqltGT;
1118	+	CR:
1119	+	Result := sqltCR;
1120	+	LF:
1121	+	Result := sqltEOL;
1122	+	else
1123	+	if C in ValidSQLIdentifierChars then
1124	+	Result := sqltIdentifier
1125	+	else
1126	+	Result := sqltOtherCharacter;
1127	+	end;
1128	+	FLastChar := C
1129	+	end;
1130	+	FNextToken := Result;
1131	+	end;
1132	+
1133	+	procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1134	+	begin
1135	+	if FQFirst = FQLast then
1136	+	IBError(ibxeTokenQueueUnderflow,[]);
1137	+	token := FTokenQueue[FQFirst].token;
1138	+	FString := FTokenQueue[FQFirst].text;
1139	+	Inc(FQFirst);
1140	+	if FQFirst = FQLast then
1141	+	FQueueState := tsHold;
1142	+	end;
1143	+
1144	+	procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1145	+	begin
1146	+	FString := source.FString;
1147	+	FNextToken := source.FNextToken;
1148	+	FTokenQueue := source.FTokenQueue;
1149	+	FQueueState := source.FQueueState;
1150	+	FQFirst := source.FQFirst;
1151	+	FQLast := source.FQLast;
1152	+	end;
1153	+
1154	+	function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1155	+	begin
1156	+	Result := (FState = stDefault);
1157	+	if Result and (token = sqltIdentifier)  then
1158	+	FindReservedWord(FString,token);
1159	+	end;
1160	+
1161	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1162	+	begin
1163	+	if FQLast > TokenQueueMaxSize then
1164	+	IBError(ibxeTokenQueueOverflow,[]);
1165	+	FTokenQueue[FQLast].token := token;
1166	+	FTokenQueue[FQLast].text := text;
1167	+	Inc(FQLast);
1168	+	end;
1169	+
1170	+	procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1171	+	begin
1172	+	QueueToken(token,TokenText);
1173	+	end;
1174	+
1175	+	procedure TSQLTokeniser.ResetQueue;
1176	+	begin
1177	+	FQFirst := 0;
1178	+	FQLast := 0;
1179	+	FQueueState := tsHold;
1180	+	end;
1181	+
1182	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1183	+	begin
1184	+	ResetQueue;
1185	+	QueueToken(token,text);
1186	+	end;
1187	+
1188	+	procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1189	+	begin
1190	+	ResetQueue;
1191	+	QueueToken(token);
1192	+	end;
1193	+
1194	+	procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1195	+	begin
1196	+	FQueueState := tsRelease;
1197	+	PopQueue(token);
1198	+	end;
1199	+
1200	+	procedure TSQLTokeniser.ReleaseQueue;
1201	+	begin
1202	+	FQueueState := tsRelease;
1203	+	end;
1204	+
1205	+	function TSQLTokeniser.GetQueuedText: AnsiString;
1206	+	var i: integer;
1207	+	begin
1208	+	Result := '';
1209	+	for i := FQFirst to FQLast do
1210	+	Result := Result + FTokenQueue[i].text;
1211	+	end;
1212	+
1213	+	procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1214	+	begin
1215	+	FString := text;
1216	+	end;
1217	+
1218	+	constructor TSQLTokeniser.Create;
1219	+	begin
1220	+	inherited Create;
1221	+	Reset;
1222	+	end;
1223	+
1224	+	destructor TSQLTokeniser.Destroy;
1225	+	begin
1226	+	Reset;
1227	+	inherited Destroy;
1228	+	end;
1229	+
1230	+	procedure TSQLTokeniser.Reset;
1231	+	begin
1232	+	FNextToken := sqltInit;
1233	+	FState := stDefault;
1234	+	FString := '';
1235	+	FEOF := false;
1236	+	ResetQueue;
1237	+	end;
1238	+
1239	+	function TSQLTokeniser.GetNextToken: TSQLTokens;
1240	+	begin
1241	+	if FQueueState = tsRelease then
1242	+	repeat
1243	+	PopQueue(Result);
1244	+	FEOF := Result = sqltEOF;
1245	+	if TokenFound(Result) then
1246	+	Exit;
1247	+	until FQueueState <> tsRelease;
1248	+
1249	+	Result := InternalGetNextToken;
1250	+	end;
1251	+
1252	+	{a simple lookahead one algorithm to extra the next symbol}
1253	+
1254	+	function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1255	+	var C: AnsiChar;
1256	+	begin
1257	+	Result := sqltEOF;
1258	+
1259	+	if FNextToken = sqltInit then
1260	+	GetNext;
1261	+
1262	+	repeat
1263	+	Result := FNextToken;
1264	+	C := FLastChar;
1265	+	GetNext;
1266	+
1267	+	if FSkipNext then
1268	+	begin
1269	+	FSkipNext := false;
1270	+	continue;
1271	+	end;
1272	+
1273	+	case FState of
1274	+	stInComment:
1275	+	begin
1276	+	if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1277	+	begin
1278	+	FState := stDefault;
1279	+	Result := sqltComment;
1280	+	GetNext;
1281	+	end
1282	+	else
1283	+	FString := FString + C;
1284	+	end;
1285	+
1286	+	stInCommentLine:
1287	+	begin
1288	+	case Result of
1289	+	sqltEOL:
1290	+	begin
1291	+	FState := stDefault;
1292	+	Result := sqltCommentLine;
1293	+	end;
1294	+
1295	+	sqltCR: {ignore};
1296	+
1297	+	else
1298	+	FString := FString + C;
1299	+	end;
1300	+	end;
1301	+
1302	+	stSingleQuoted:
1303	+	begin
1304	+	if (Result = sqltSingleQuotes) then
1305	+	begin
1306	+	if (FNextToken = sqltSingleQuotes) then
1307	+	begin
1308	+	FSkipNext := true;
1309	+	FString := FString + C;
1310	+	end
1311	+	else
1312	+	begin
1313	+	Result := sqltQuotedString;
1314	+	FState := stDefault;
1315	+	end;
1316	+	end
1317	+	else
1318	+	FString := FString + C;
1319	+	end;
1320	+
1321	+	stDoubleQuoted:
1322	+	begin
1323	+	if (Result = sqltDoubleQuotes) then
1324	+	begin
1325	+	if (FNextToken = sqltDoubleQuotes) then
1326	+	begin
1327	+	FSkipNext := true;
1328	+	FString := FString + C;
1329	+	end
1330	+	else
1331	+	begin
1332	+	Result := sqltIdentifierInDoubleQuotes;
1333	+	FState := stDefault;
1334	+	end;
1335	+	end
1336	+	else
1337	+	FString := FString + C;
1338	+	end;
1339	+
1340	+	stInIdentifier:
1341	+	begin
1342	+	FString := FString + C;
1343	+	Result := sqltIdentifier;
1344	+	if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1345	+	FState := stDefault
1346	+	end;
1347	+
1348	+	stInNumeric:
1349	+	begin
1350	+	FString := FString + C;
1351	+	if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1352	+	begin
1353	+	{malformed decimal}
1354	+	FState := stInIdentifier;
1355	+	Result := sqltIdentifier
1356	+	end
1357	+	else
1358	+	begin
1359	+	if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1360	+	FState := stDefault;
1361	+	Result := sqltNumberString;
1362	+	end;
1363	+	end;
1364	+
1365	+	else {stDefault}
1366	+	begin
1367	+	FString := C;
1368	+	case Result of
1369	+
1370	+	sqltPipe:
1371	+	if FNextToken = sqltPipe then
1372	+	begin
1373	+	Result := sqltConcatSymbol;
1374	+	FString := C + FLastChar;
1375	+	GetNext;
1376	+	end;
1377	+
1378	+	sqltForwardSlash:
1379	+	begin
1380	+	if FNextToken = sqltAsterisk then
1381	+	begin
1382	+	FString := '';
1383	+	GetNext;
1384	+	FState := stInComment;
1385	+	end
1386	+	else
1387	+	if FNextToken = sqltForwardSlash then
1388	+	begin
1389	+	FString := '';
1390	+	GetNext;
1391	+	FState := stInCommentLine;
1392	+	end;
1393	+	end;
1394	+
1395	+	sqltSingleQuotes:
1396	+	begin
1397	+	FString := '';
1398	+	FState := stSingleQuoted;
1399	+	end;
1400	+
1401	+	sqltDoubleQuotes:
1402	+	begin
1403	+	FString := '';
1404	+	FState := stDoubleQuoted;
1405	+	end;
1406	+
1407	+	sqltIdentifier:
1408	+	if FNextToken in [sqltIdentifier,sqltNumberString] then
1409	+	FState := stInIdentifier;
1410	+
1411	+	sqltNumberString:
1412	+	if FNextToken in [sqltNumberString,sqltPeriod] then
1413	+	FState := stInNumeric;
1414	+	end;
1415	+	end;
1416	+	end;
1417	+
1418	+	//    writeln(FString);
1419	+	FEOF := Result = sqltEOF;
1420	+	until TokenFound(Result) or EOF;
1421	+	end;
1422	+
1423		end.

Diff Legend

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