ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/IBUtils.pas
File size: 32015 byte(s)
Log Message:
Release 2.3.2 committed

File Contents

# User Rev Content
1 tony 45 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 Inprise Corporation }
7     { }
8     { InterBase Express is based in part on the product }
9     { Free IB Components, written by Gregory H. Deatz for }
10     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11     { Free IB Components is used under license. }
12     { }
13     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     { IBX For Lazarus (Firebird Express) }
28     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29     { Portions created by MWA Software are copyright McCallum Whyman }
30     { Associates Ltd 2011 }
31     { }
32     {************************************************************************}
33    
34     unit IBUtils;
35 tony 56 {$IFDEF MSWINDOWS}
36 tony 118 {$DEFINE WINDOWS}
37 tony 56 {$ENDIF}
38 tony 45
39     {$IFDEF FPC}
40     {$Mode Delphi}
41     {$codepage UTF8}
42 tony 118 {$define HASREQEX}
43 tony 45 {$ENDIF}
44    
45 tony 118
46 tony 45 interface
47    
48 tony 143 uses Classes, SysUtils, IB;
49 tony 45
50 tony 263 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 tony 45 const
294     CRLF = #13 + #10;
295     CR = #13;
296     LF = #10;
297     TAB = #9;
298     NULL_TERMINATOR = #0;
299    
300 tony 263 {$IFNDEF FPC}
301     LineEnding = CRLF;
302     {$ENDIF}
303    
304     {SQL Reserved words in alphabetical order}
305    
306     sqlReservedWords: array [TSQLReservedWords] of string = (
307 tony 47 'ADD',
308     'ADMIN',
309     'ALL',
310     'ALTER',
311     'AND',
312     'ANY',
313     'AS',
314     'AT',
315     'AVG',
316     'BEGIN',
317     'BETWEEN',
318     'BIGINT',
319     'BIT_LENGTH',
320     'BLOB',
321     'BOOLEAN',
322     'BOTH',
323     'BY',
324     'CASE',
325     'CAST',
326     'CHAR',
327     'CHAR_LENGTH',
328     'CHARACTER',
329     'CHARACTER_LENGTH',
330     'CHECK',
331     'CLOSE',
332     'COLLATE',
333     'COLUMN',
334     'COMMIT',
335     'CONNECT',
336     'CONSTRAINT',
337     'CORR',
338     'COUNT',
339     'COVAR_POP',
340     'COVAR_SAMP',
341     'CREATE',
342     'CROSS',
343     'CURRENT',
344     'CURRENT_CONNECTION',
345     'CURRENT_DATE',
346     'CURRENT_ROLE',
347     'CURRENT_TIME',
348     'CURRENT_TIMESTAMP',
349     'CURRENT_TRANSACTION',
350     'CURRENT_USER',
351     'CURSOR',
352     'DATE',
353     'DAY',
354     'DEC',
355     'DECIMAL',
356     'DECLARE',
357     'DEFAULT',
358     'DELETE',
359     'DELETING',
360     'DETERMINISTIC',
361     'DISCONNECT',
362     'DISTINCT',
363     'DOUBLE',
364     'DROP',
365     'ELSE',
366     'END',
367     'ESCAPE',
368     'EXECUTE',
369     'EXISTS',
370     'EXTERNAL',
371     'EXTRACT',
372     'FALSE',
373     'FETCH',
374     'FILTER',
375     'FLOAT',
376     'FOR',
377     'FOREIGN',
378     'FROM',
379     'FULL',
380     'FUNCTION',
381     'GDSCODE',
382     'GLOBAL',
383     'GRANT',
384     'GROUP',
385     'HAVING',
386     'HOUR',
387     'IN',
388     'INDEX',
389     'INNER',
390     'INSENSITIVE',
391     'INSERT',
392     'INSERTING',
393     'INT',
394     'INTEGER',
395     'INTO',
396     'IS',
397     'JOIN',
398 tony 209 'KEY',
399 tony 47 'LEADING',
400     'LEFT',
401     'LIKE',
402     'LONG',
403     'LOWER',
404     'MAX',
405     'MAXIMUM_SEGMENT',
406     'MERGE',
407     'MIN',
408     'MINUTE',
409     'MONTH',
410     'NATIONAL',
411     'NATURAL',
412     'NCHAR',
413     'NO',
414     'NOT',
415     'NULL',
416     'NUMERIC',
417     'OCTET_LENGTH',
418     'OF',
419     'OFFSET',
420     'ON',
421     'ONLY',
422     'OPEN',
423     'OR',
424     'ORDER',
425     'OUTER',
426     'OVER',
427     'PARAMETER',
428     'PLAN',
429     'POSITION',
430     'POST_EVENT',
431     'PRECISION',
432     'PRIMARY',
433     'PROCEDURE',
434     'RDB$DB_KEY',
435     'RDB$RECORD_VERSION',
436     'REAL',
437     'RECORD_VERSION',
438     'RECREATE',
439     'RECURSIVE',
440     'REFERENCES',
441     'REGR_AVGX',
442     'REGR_AVGY',
443     'REGR_COUNT',
444     'REGR_INTERCEPT',
445     'REGR_R2',
446     'REGR_SLOPE',
447     'REGR_SXX',
448     'REGR_SXY',
449     'REGR_SYY',
450     'RELEASE',
451     'RETURN',
452     'RETURNING_VALUES',
453     'RETURNS',
454     'REVOKE',
455     'RIGHT',
456     'ROLLBACK',
457     'ROW',
458 tony 263 'ROWS',
459 tony 47 'ROW_COUNT',
460     'SAVEPOINT',
461     'SCROLL',
462     'SECOND',
463     'SELECT',
464     'SENSITIVE',
465     'SET',
466     'SIMILAR',
467     'SMALLINT',
468     'SOME',
469     'SQLCODE',
470     'SQLSTATE',
471     'START',
472     'STDDEV_POP',
473     'STDDEV_SAMP',
474     'SUM',
475     'TABLE',
476     'THEN',
477     'TIME',
478     'TIMESTAMP',
479     'TO',
480     'TRAILING',
481     'TRIGGER',
482     'TRIM',
483     'TRUE',
484     'UNION',
485     'UNIQUE',
486     'UNKNOWN',
487     'UPDATE',
488     'UPDATING',
489     'UPPER',
490     'USER',
491     'USING',
492     'VALUE',
493     'VALUES',
494     'VAR_POP',
495     'VAR_SAMP',
496     'VARCHAR',
497     'VARIABLE',
498     'VARYING',
499     'VIEW',
500     'WHEN',
501     'WHERE',
502     'WHILE',
503     'WITH',
504     'YEAR'
505     );
506 tony 45
507 tony 263 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 tony 45 function Max(n1, n2: Integer): Integer;
596     function Min(n1, n2: Integer): Integer;
597 tony 56 function RandomString(iLength: Integer): AnsiString;
598 tony 45 function RandomInteger(iLow, iHigh: Integer): Integer;
599 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
600     function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
601 tony 263 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
602     function IsReservedWord(w: AnsiString): boolean;
603 tony 56 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 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
608 tony 117 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
609 tony 143 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 tony 45
616     implementation
617    
618 tony 263 uses FBMessages
619    
620 tony 118 {$IFDEF HASREQEX}
621 tony 263 ,RegExpr
622     {$ENDIF};
623 tony 117
624 tony 45 function Max(n1, n2: Integer): Integer;
625     begin
626     if (n1 > n2) then
627     result := n1
628     else
629     result := n2;
630     end;
631    
632     function Min(n1, n2: Integer): Integer;
633     begin
634     if (n1 < n2) then
635     result := n1
636     else
637     result := n2;
638     end;
639    
640 tony 56 function RandomString(iLength: Integer): AnsiString;
641 tony 45 begin
642     result := '';
643     while Length(result) < iLength do
644     result := result + IntToStr(RandomInteger(0, High(Integer)));
645     if Length(result) > iLength then
646     result := Copy(result, 1, iLength);
647     end;
648    
649     function RandomInteger(iLow, iHigh: Integer): Integer;
650     begin
651     result := Trunc(Random(iHigh - iLow)) + iLow;
652     end;
653    
654 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
655 tony 45 var
656     i: Integer;
657     begin
658     result := '';
659     for i := 1 to Length(st) do begin
660     if AnsiPos(st[i], CharsToStrip) = 0 then
661     result := result + st[i];
662     end;
663     end;
664    
665 tony 117 {Extracts SQL Identifier typically from a Dialect 3 encoding}
666 tony 45
667 tony 117 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
668 tony 45 begin
669     Value := Trim(Value);
670     if Dialect = 1 then
671     Value := AnsiUpperCase(Value)
672     else
673     begin
674     if (Value <> '') and (Value[1] = '"') then
675     begin
676     Delete(Value, 1, 1);
677     Delete(Value, Length(Value), 1);
678     Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
679     end
680     else
681     Value := AnsiUpperCase(Value);
682     end;
683     Result := Value;
684     end;
685    
686 tony 263 {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 tony 117 {Returns true if "w" is a Firebird SQL reserved word}
708 tony 45
709 tony 56 function IsReservedWord(w: AnsiString): boolean;
710 tony 263 var token: TSQLTokens;
711 tony 45 begin
712 tony 263 Result := FindReservedWord(w,token);
713 tony 45 end;
714    
715 tony 117 {Format an SQL Identifier according to SQL Dialect}
716    
717 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
718 tony 45 begin
719     if Dialect = 1 then
720     Value := AnsiUpperCase(Trim(Value))
721     else
722 tony 117 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
723 tony 45 Result := Value;
724     end;
725    
726 tony 107 const
727     ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
728    
729 tony 117 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
730    
731 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
732     var i: integer;
733     begin
734     Result := false;
735     for i := 1 to Length(Value) do
736     if not (Value[i] in ValidSQLIdentifierChars) then Exit;
737     Result := true;
738     end;
739    
740 tony 117 {Extracts the Database Connect string from a Create Database Statement}
741    
742 tony 118 {$IFDEF HASREQEX}
743 tony 117 function ExtractConnectString(const CreateSQL: AnsiString;
744     var ConnectString: AnsiString): boolean;
745     var RegexObj: TRegExpr;
746     begin
747     RegexObj := TRegExpr.Create;
748     try
749     {extact database file spec}
750     RegexObj.ModifierG := false; {turn off greedy matches}
751     RegexObj.ModifierI := true; {case insensitive match}
752     RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
753     Result := RegexObj.Exec(CreateSQL);
754     if Result then
755 tony 143 ConnectString := RegexObj.Match[2];
756 tony 117 finally
757     RegexObj.Free;
758     end;
759     end;
760 tony 143
761     function ParseConnectString(ConnectString: AnsiString; var ServerName,
762     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
763     ): boolean;
764 tony 231
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 tony 143 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 tony 231 RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
795 tony 143 Result := RegexObj.Exec(ConnectString);
796     if Result then
797     begin
798     {URL type connect string}
799 tony 231 Protocol := GetProtocol(RegexObj.Match[1]);
800 tony 143 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 tony 231 if ServerName = '' then
805     DatabaseName := '/' + DatabaseName;
806 tony 143 end
807     else
808     begin
809 tony 231 {URL type connect string - local loop}
810     RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
811 tony 143 Result := RegexObj.Exec(ConnectString);
812     if Result then
813 tony 231 begin
814     Protocol := GetProtocol(RegexObj.Match[1]);
815     DatabaseName := RegexObj.Match[2];
816     end
817 tony 143 else
818     begin
819 tony 231 RegexObj.Expression := '^([a-zA-Z]:\\.*)';
820 tony 143 Result := RegexObj.Exec(ConnectString);
821     if Result then
822 tony 231 Protocol := Local {Windows with leading drive ID}
823 tony 143 else
824     begin
825 tony 231 RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
826 tony 143 Result := RegexObj.Exec(ConnectString);
827     if Result then
828     begin
829 tony 231 {Legacy TCP Format}
830 tony 143 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 tony 231 Protocol := TCP;
835 tony 143 end
836     else
837     begin
838 tony 231 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 tony 143 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 tony 118 {$ELSE}
872 tony 121 {cruder version of above for Delphi. Older versions lack regular expression
873     handling.}
874 tony 118 function ExtractConnectString(const CreateSQL: AnsiString;
875     var ConnectString: AnsiString): boolean;
876     var i: integer;
877     begin
878     Result := false;
879     i := Pos('''',CreateSQL);
880     if i > 0 then
881     begin
882     ConnectString := CreateSQL;
883     delete(ConnectString,1,i);
884     i := Pos('''',ConnectString);
885     if i > 0 then
886     begin
887     delete(ConnectString,i,Length(ConnectString)-i+1);
888     Result := true;
889     end;
890     end;
891     end;
892 tony 143
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 tony 118 {$ENDIF}
906 tony 117
907 tony 143 {Make a connect string in format appropriate protocol}
908    
909     function MakeConnectString(ServerName, DatabaseName: AnsiString;
910     Protocol: TProtocol; PortNo: AnsiString): AnsiString;
911 tony 231
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 tony 143 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 tony 231 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 tony 143 end;
945     end;
946    
947 tony 117 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
948    
949 tony 56 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
950 tony 45 begin
951     if (Dialect = 3) and
952 tony 115 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
953 tony 117 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
954 tony 45 else
955     Result := Value
956     end;
957    
958 tony 117 {Replaces unknown characters in a string with underscores}
959    
960 tony 56 function Space2Underscore(s: AnsiString): AnsiString;
961 tony 45 var
962     k: integer;
963     begin
964     Result := s;
965     for k := 1 to Length(s) do
966 tony 117 if not (Result[k] in ValidSQLIdentifierChars) then
967 tony 45 Result[k] := '_';
968     end;
969    
970 tony 117 {Reformats an SQL string with single quotes duplicated.}
971    
972 tony 56 function SQLSafeString(const s: AnsiString): AnsiString;
973 tony 47 begin
974     Result := StringReplace(s,'''','''''',[rfReplaceAll]);
975     end;
976 tony 45
977 tony 263 { 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 = sqltIdentifier 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 tony 45 end.