ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/IBUtils.pas
File size: 44441 byte(s)
Log Message:
Updated for IBX 4 release

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     {$ENDIF}
43    
44 tony 315 { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45     { $define HASDELPHIREQEX}
46     { $IFEND}
47 tony 118
48 tony 45 interface
49    
50 tony 143 uses Classes, SysUtils, IB;
51 tony 45
52 tony 263 type
53     TSQLTokens = (
54    
55     {Reserved Words}
56    
57     sqltAdd,
58     sqltAdmin,
59     sqltAll,
60     sqltAlter,
61     sqltAnd,
62     sqltAny,
63     sqltAs,
64     sqltAt,
65     sqltAvg,
66     sqltBegin,
67     sqltBetween,
68     sqltBigint,
69     sqltBit_Length,
70     sqltBlob,
71     sqltBoolean,
72     sqltBoth,
73     sqltBy,
74     sqltCase,
75     sqltCast,
76     sqltChar,
77     sqltChar_Length,
78     sqltCharacter,
79     sqltCharacter_Length,
80     sqltCheck,
81     sqltClose,
82     sqltCollate,
83     sqltColumn,
84     sqltCommit,
85     sqltConnect,
86     sqltConstraint,
87     sqltCorr,
88     sqltCount,
89     sqltCovar_Pop,
90     sqltCovar_Samp,
91     sqltCreate,
92     sqltCross,
93     sqltCurrent,
94     sqltCurrent_Connection,
95     sqltCurrent_Date,
96     sqltCurrent_Role,
97     sqltCurrent_Time,
98     sqltCurrent_Timestamp,
99     sqltCurrent_Transaction,
100     sqltCurrent_User,
101     sqltCursor,
102     sqltDate,
103     sqltDay,
104     sqltDec,
105     sqltDecimal,
106     sqltDeclare,
107     sqltDefault,
108     sqltDelete,
109     sqltDeleting,
110     sqltDeterministic,
111     sqltDisconnect,
112     sqltDistinct,
113     sqltDouble,
114     sqltDrop,
115     sqltElse,
116     sqltEnd,
117     sqltEscape,
118     sqltExecute,
119     sqltExists,
120     sqltExternal,
121     sqltExtract,
122     sqltFalse,
123     sqltFetch,
124     sqltFilter,
125     sqltFloat,
126     sqltFor,
127     sqltForeign,
128     sqltFrom,
129     sqltFull,
130     sqltFunction,
131     sqltGdscode,
132     sqltGlobal,
133     sqltGrant,
134     sqltGroup,
135     sqltHaving,
136     sqltHour,
137     sqltIn,
138     sqltIndex,
139     sqltInner,
140     sqltInsensitive,
141     sqltInsert,
142     sqltInserting,
143     sqltInt,
144     sqltInteger,
145     sqltInto,
146     sqltIs,
147     sqltJoin,
148     sqltKey,
149     sqltLeading,
150     sqltLeft,
151     sqltLike,
152     sqltLong,
153     sqltLower,
154     sqltMax,
155     sqltMaximum_Segment,
156     sqltMerge,
157     sqltMin,
158     sqltMinute,
159     sqltMonth,
160     sqltNational,
161     sqltNatural,
162     sqltNchar,
163     sqltNo,
164     sqltNot,
165     sqltNull,
166     sqltNumeric,
167     sqltOctet_Length,
168     sqltOf,
169     sqltOffset,
170     sqltOn,
171     sqltOnly,
172     sqltOpen,
173     sqltOr,
174     sqltOrder,
175     sqltOuter,
176     sqltOver,
177     sqltParameter,
178     sqltPlan,
179     sqltPosition,
180     sqltPost_Event,
181     sqltPrecision,
182     sqltPrimary,
183     sqltProcedure,
184     sqltRdbDb_Key,
185     sqltRdbRecord_Version,
186     sqltReal,
187     sqltRecord_Version,
188     sqltRecreate,
189     sqltRecursive,
190     sqltReferences,
191     sqltRegr_Avgx,
192     sqltRegr_Avgy,
193     sqltRegr_Count,
194     sqltRegr_Intercept,
195     sqltRegr_R2,
196     sqltRegr_Slope,
197     sqltRegr_Sxx,
198     sqltRegr_Sxy,
199     sqltRegr_Syy,
200     sqltRelease,
201     sqltReturn,
202     sqltReturning_Values,
203     sqltReturns,
204     sqltRevoke,
205     sqltRight,
206     sqltRollback,
207     sqltRow,
208     sqltRows,
209     sqltRow_Count,
210     sqltSavepoint,
211     sqltScroll,
212     sqltSecond,
213     sqltSelect,
214     sqltSensitive,
215     sqltSet,
216     sqltSimilar,
217     sqltSmallint,
218     sqltSome,
219     sqltSqlcode,
220     sqltSqlstate,
221     sqltStart,
222     sqltStddev_Pop,
223     sqltStddev_Samp,
224     sqltSum,
225     sqltTable,
226     sqltThen,
227     sqltTime,
228     sqltTimestamp,
229     sqltTo,
230     sqltTrailing,
231     sqltTrigger,
232     sqltTrim,
233     sqltTrue,
234     sqltUnion,
235     sqltUnique,
236     sqltUnknown,
237     sqltUpdate,
238     sqltUpdating,
239     sqltUpper,
240     sqltUser,
241     sqltUsing,
242     sqltValue,
243     sqltValues,
244     sqltVar_Pop,
245     sqltVar_Samp,
246     sqltVarchar,
247     sqltVariable,
248     sqltVarying,
249     sqltView,
250     sqltWhen,
251     sqltWhere,
252     sqltWhile,
253     sqltWith,
254     sqltYear,
255    
256     {symbols}
257    
258     sqltSpace,
259     sqltSemiColon,
260     sqltPlaceholder,
261     sqltSingleQuotes,
262     sqltDoubleQuotes,
263 tony 270 sqltBackslash,
264 tony 263 sqltComma,
265     sqltPeriod,
266     sqltEquals,
267     sqltOtherCharacter,
268     sqltIdentifier,
269     sqltIdentifierInDoubleQuotes,
270     sqltNumberString,
271     sqltString,
272     sqltParam,
273     sqltQuotedParam,
274     sqltColon,
275     sqltComment,
276     sqltCommentLine,
277     sqltQuotedString,
278     sqltAsterisk,
279     sqltForwardSlash,
280     sqltOpenSquareBracket,
281     sqltCloseSquareBracket,
282     sqltOpenBracket,
283     sqltCloseBracket,
284     sqltPipe,
285 tony 287 sqltMinus,
286 tony 263 sqltConcatSymbol,
287     sqltLT,
288     sqltGT,
289     sqltCR,
290     sqltEOL,
291     sqltEOF,
292     sqltInit
293     );
294    
295     TSQLReservedWords = sqltAdd..sqltYear;
296    
297 tony 45 const
298     CRLF = #13 + #10;
299     CR = #13;
300     LF = #10;
301     TAB = #9;
302     NULL_TERMINATOR = #0;
303    
304 tony 263 {$IFNDEF FPC}
305     LineEnding = CRLF;
306     {$ENDIF}
307    
308     {SQL Reserved words in alphabetical order}
309    
310     sqlReservedWords: array [TSQLReservedWords] of string = (
311 tony 47 'ADD',
312     'ADMIN',
313     'ALL',
314     'ALTER',
315     'AND',
316     'ANY',
317     'AS',
318     'AT',
319     'AVG',
320     'BEGIN',
321     'BETWEEN',
322     'BIGINT',
323     'BIT_LENGTH',
324     'BLOB',
325     'BOOLEAN',
326     'BOTH',
327     'BY',
328     'CASE',
329     'CAST',
330     'CHAR',
331     'CHAR_LENGTH',
332     'CHARACTER',
333     'CHARACTER_LENGTH',
334     'CHECK',
335     'CLOSE',
336     'COLLATE',
337     'COLUMN',
338     'COMMIT',
339     'CONNECT',
340     'CONSTRAINT',
341     'CORR',
342     'COUNT',
343     'COVAR_POP',
344     'COVAR_SAMP',
345     'CREATE',
346     'CROSS',
347     'CURRENT',
348     'CURRENT_CONNECTION',
349     'CURRENT_DATE',
350     'CURRENT_ROLE',
351     'CURRENT_TIME',
352     'CURRENT_TIMESTAMP',
353     'CURRENT_TRANSACTION',
354     'CURRENT_USER',
355     'CURSOR',
356     'DATE',
357     'DAY',
358     'DEC',
359     'DECIMAL',
360     'DECLARE',
361     'DEFAULT',
362     'DELETE',
363     'DELETING',
364     'DETERMINISTIC',
365     'DISCONNECT',
366     'DISTINCT',
367     'DOUBLE',
368     'DROP',
369     'ELSE',
370     'END',
371     'ESCAPE',
372     'EXECUTE',
373     'EXISTS',
374     'EXTERNAL',
375     'EXTRACT',
376     'FALSE',
377     'FETCH',
378     'FILTER',
379     'FLOAT',
380     'FOR',
381     'FOREIGN',
382     'FROM',
383     'FULL',
384     'FUNCTION',
385     'GDSCODE',
386     'GLOBAL',
387     'GRANT',
388     'GROUP',
389     'HAVING',
390     'HOUR',
391     'IN',
392     'INDEX',
393     'INNER',
394     'INSENSITIVE',
395     'INSERT',
396     'INSERTING',
397     'INT',
398     'INTEGER',
399     'INTO',
400     'IS',
401     'JOIN',
402 tony 209 'KEY',
403 tony 47 'LEADING',
404     'LEFT',
405     'LIKE',
406     'LONG',
407     'LOWER',
408     'MAX',
409     'MAXIMUM_SEGMENT',
410     'MERGE',
411     'MIN',
412     'MINUTE',
413     'MONTH',
414     'NATIONAL',
415     'NATURAL',
416     'NCHAR',
417     'NO',
418     'NOT',
419     'NULL',
420     'NUMERIC',
421     'OCTET_LENGTH',
422     'OF',
423     'OFFSET',
424     'ON',
425     'ONLY',
426     'OPEN',
427     'OR',
428     'ORDER',
429     'OUTER',
430     'OVER',
431     'PARAMETER',
432     'PLAN',
433     'POSITION',
434     'POST_EVENT',
435     'PRECISION',
436     'PRIMARY',
437     'PROCEDURE',
438     'RDB$DB_KEY',
439     'RDB$RECORD_VERSION',
440     'REAL',
441     'RECORD_VERSION',
442     'RECREATE',
443     'RECURSIVE',
444     'REFERENCES',
445     'REGR_AVGX',
446     'REGR_AVGY',
447     'REGR_COUNT',
448     'REGR_INTERCEPT',
449     'REGR_R2',
450     'REGR_SLOPE',
451     'REGR_SXX',
452     'REGR_SXY',
453     'REGR_SYY',
454     'RELEASE',
455     'RETURN',
456     'RETURNING_VALUES',
457     'RETURNS',
458     'REVOKE',
459     'RIGHT',
460     'ROLLBACK',
461     'ROW',
462 tony 263 'ROWS',
463 tony 47 'ROW_COUNT',
464     'SAVEPOINT',
465     'SCROLL',
466     'SECOND',
467     'SELECT',
468     'SENSITIVE',
469     'SET',
470     'SIMILAR',
471     'SMALLINT',
472     'SOME',
473     'SQLCODE',
474     'SQLSTATE',
475     'START',
476     'STDDEV_POP',
477     'STDDEV_SAMP',
478     'SUM',
479     'TABLE',
480     'THEN',
481     'TIME',
482     'TIMESTAMP',
483     'TO',
484     'TRAILING',
485     'TRIGGER',
486     'TRIM',
487     'TRUE',
488     'UNION',
489     'UNIQUE',
490     'UNKNOWN',
491     'UPDATE',
492     'UPDATING',
493     'UPPER',
494     'USER',
495     'USING',
496     'VALUE',
497     'VALUES',
498     'VAR_POP',
499     'VAR_SAMP',
500     'VARCHAR',
501     'VARIABLE',
502     'VARYING',
503     'VIEW',
504     'WHEN',
505     'WHERE',
506     'WHILE',
507     'WITH',
508     'YEAR'
509     );
510 tony 45
511 tony 263 type
512     {The TSQLTokeniser class provides a common means to parse an SQL statement, or
513     even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
514     with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
515     is instantiated with a stream from which the SQL statements are read.
516    
517     Successive calls to GetNextToken then return each SQL token. The TokenText contains
518     either the single character, the identifier or reserved word, the string or comment.}
519    
520     { TSQLTokeniser }
521    
522     TSQLTokeniser = class
523     private
524     const
525     TokenQueueMaxSize = 64;
526     type
527     TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
528     stInIdentifier, stInNumeric);
529    
530     TTokenQueueItem = record
531     token: TSQLTokens;
532     text: AnsiString;
533     end;
534     TTokenQueueState = (tsHold, tsRelease);
535    
536     private
537     FLastChar: AnsiChar;
538     FState: TLexState;
539     FSkipNext: boolean;
540     function GetNext: TSQLTokens;
541    
542     {The token Queue is available for use by descendents so that they can
543     hold back tokens in order to lookahead by token rather than just a single
544     character}
545    
546     private
547     FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
548     FQueueState: TTokenQueueState;
549     FQFirst: integer; {first and last pointers first=last => queue empty}
550     FQLast: integer;
551     FEOF: boolean;
552     procedure PopQueue(var token: TSQLTokens);
553     protected
554     FString: AnsiString;
555     FNextToken: TSQLTokens;
556     procedure Assign(source: TSQLTokeniser); virtual;
557     function GetChar: AnsiChar; virtual; abstract;
558     function TokenFound(var token: TSQLTokens): boolean; virtual;
559     function InternalGetNextToken: TSQLTokens; virtual;
560     procedure Reset; virtual;
561    
562     {Token stack}
563     procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
564     procedure QueueToken(token: TSQLTokens); overload;
565     procedure ResetQueue; overload;
566     procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
567     procedure ResetQueue(token: TSQLTokens); overload;
568     procedure ReleaseQueue(var token: TSQLTokens); overload;
569     procedure ReleaseQueue; overload;
570     function GetQueuedText: AnsiString;
571     procedure SetTokenText(text: AnsiString);
572    
573     public
574     const
575     DefaultTerminator = ';';
576     public
577     constructor Create;
578     destructor Destroy; override;
579     function GetNextToken: TSQLTokens;
580     property EOF: boolean read FEOF;
581     property TokenText: AnsiString read FString;
582     end;
583    
584     { TSQLwithNamedParamsTokeniser }
585    
586     TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
587     private
588     type
589     TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
590     private
591     FState: TSQLState;
592     FNested: integer;
593     protected
594     procedure Assign(source: TSQLTokeniser); override;
595     procedure Reset; override;
596     function TokenFound(var token: TSQLTokens): boolean; override;
597     end;
598    
599 tony 270 { TSQLParamProcessor }
600    
601     TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
602     private
603     const
604     sIBXParam = 'IBXParam'; {do not localize}
605     private
606     FInString: AnsiString;
607     FIndex: integer;
608     function DoExecute(GenerateParamNames: boolean;
609     var slNames: TStrings): AnsiString;
610     protected
611     function GetChar: AnsiChar; override;
612     public
613     class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
614     var slNames: TStrings): AnsiString;
615     end;
616    
617    
618 tony 45 function Max(n1, n2: Integer): Integer;
619     function Min(n1, n2: Integer): Integer;
620 tony 56 function RandomString(iLength: Integer): AnsiString;
621 tony 45 function RandomInteger(iLow, iHigh: Integer): Integer;
622 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
623     function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624 tony 263 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
625     function IsReservedWord(w: AnsiString): boolean;
626 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
627     function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
628     function Space2Underscore(s: AnsiString): AnsiString;
629     function SQLSafeString(const s: AnsiString): AnsiString;
630 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
631 tony 117 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
632 tony 143 function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
633     PortNo: AnsiString = ''): AnsiString;
634     function ParseConnectString(ConnectString: AnsiString;
635     var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
636     var PortNo: AnsiString): boolean;
637     function GetProtocol(ConnectString: AnsiString): TProtocolAll;
638 tony 45
639 tony 315 {$IF declared(TFormatSettings)}
640     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
641     var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
642     {$IFEND}
643     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
644     var aTimezone: AnsiString; TimeOnly: boolean=false): boolean; overload;
645     procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
646     function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
647     function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
648     function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
649     function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
650     function StripLeadingZeros(Value: AnsiString): AnsiString;
651    
652 tony 45 implementation
653    
654 tony 263 uses FBMessages
655    
656 tony 315 {$IFDEF FPC}
657 tony 263 ,RegExpr
658 tony 315 {$ELSE}
659     {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
660     , RegularExpressions
661     {$IFEND}
662 tony 263 {$ENDIF};
663 tony 117
664 tony 315
665 tony 45 function Max(n1, n2: Integer): Integer;
666     begin
667     if (n1 > n2) then
668     result := n1
669     else
670     result := n2;
671     end;
672    
673     function Min(n1, n2: Integer): Integer;
674     begin
675     if (n1 < n2) then
676     result := n1
677     else
678     result := n2;
679     end;
680    
681 tony 56 function RandomString(iLength: Integer): AnsiString;
682 tony 45 begin
683     result := '';
684     while Length(result) < iLength do
685     result := result + IntToStr(RandomInteger(0, High(Integer)));
686     if Length(result) > iLength then
687     result := Copy(result, 1, iLength);
688     end;
689    
690     function RandomInteger(iLow, iHigh: Integer): Integer;
691     begin
692     result := Trunc(Random(iHigh - iLow)) + iLow;
693     end;
694    
695 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
696 tony 45 var
697     i: Integer;
698     begin
699     result := '';
700     for i := 1 to Length(st) do begin
701     if AnsiPos(st[i], CharsToStrip) = 0 then
702     result := result + st[i];
703     end;
704     end;
705    
706 tony 117 {Extracts SQL Identifier typically from a Dialect 3 encoding}
707 tony 45
708 tony 117 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
709 tony 45 begin
710     Value := Trim(Value);
711     if Dialect = 1 then
712     Value := AnsiUpperCase(Value)
713     else
714     begin
715     if (Value <> '') and (Value[1] = '"') then
716     begin
717     Delete(Value, 1, 1);
718     Delete(Value, Length(Value), 1);
719     Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
720     end
721     else
722     Value := AnsiUpperCase(Value);
723     end;
724     Result := Value;
725     end;
726    
727 tony 263 {Returns true if "w" is a Firebird SQL reserved word, and the
728     corresponding TSQLTokens value.}
729    
730     function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
731     var i: TSQLTokens;
732     begin
733     Result := true;
734     w := AnsiUpperCase(Trim(w));
735     for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
736     begin
737     if w = sqlReservedWords[i] then
738     begin
739     token := i;
740     Exit;
741     end;
742     if w < sqlReservedWords[i] then
743     break;
744     end;
745     Result := false;
746     end;
747    
748 tony 117 {Returns true if "w" is a Firebird SQL reserved word}
749 tony 45
750 tony 56 function IsReservedWord(w: AnsiString): boolean;
751 tony 263 var token: TSQLTokens;
752 tony 45 begin
753 tony 263 Result := FindReservedWord(w,token);
754 tony 45 end;
755    
756 tony 117 {Format an SQL Identifier according to SQL Dialect}
757    
758 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
759 tony 45 begin
760 tony 311 Value := TrimRight(Value);
761 tony 45 if Dialect = 1 then
762 tony 311 Value := AnsiUpperCase(Value)
763 tony 45 else
764 tony 117 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
765 tony 45 Result := Value;
766     end;
767    
768 tony 107 const
769     ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
770    
771 tony 117 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
772    
773 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
774     var i: integer;
775     begin
776     Result := false;
777     for i := 1 to Length(Value) do
778     if not (Value[i] in ValidSQLIdentifierChars) then Exit;
779     Result := true;
780     end;
781    
782 tony 315 function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
783     begin
784     scheme := AnsiUpperCase(scheme);
785     if scheme = 'INET' then
786     Result := inet
787     else
788     if scheme = 'INET4' then
789     Result := inet4
790     else
791     if scheme = 'INET6' then
792     Result := inet6
793     else
794     if scheme = 'XNET' then
795     Result := xnet
796     else
797     if scheme = 'WNET' then
798     Result := wnet
799     end;
800    
801 tony 117 {Extracts the Database Connect string from a Create Database Statement}
802    
803 tony 315 {$IF declared(TRegexpr)}
804 tony 117 function ExtractConnectString(const CreateSQL: AnsiString;
805     var ConnectString: AnsiString): boolean;
806     var RegexObj: TRegExpr;
807     begin
808     RegexObj := TRegExpr.Create;
809     try
810     {extact database file spec}
811     RegexObj.ModifierG := false; {turn off greedy matches}
812     RegexObj.ModifierI := true; {case insensitive match}
813     RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
814     Result := RegexObj.Exec(CreateSQL);
815     if Result then
816 tony 143 ConnectString := RegexObj.Match[2];
817 tony 117 finally
818     RegexObj.Free;
819     end;
820     end;
821 tony 143
822     function ParseConnectString(ConnectString: AnsiString; var ServerName,
823     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
824     ): boolean;
825 tony 231
826 tony 143 var RegexObj: TRegExpr;
827     begin
828     ServerName := '';
829     DatabaseName := ConnectString;
830     PortNo := '';
831     Protocol := unknownProtocol;
832     RegexObj := TRegExpr.Create;
833     try
834     {extact database file spec}
835     RegexObj.ModifierG := false; {turn off greedy matches}
836 tony 231 RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
837 tony 143 Result := RegexObj.Exec(ConnectString);
838     if Result then
839     begin
840     {URL type connect string}
841 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
842 tony 143 ServerName := RegexObj.Match[2];
843     if RegexObj.MatchLen[3] > 0 then
844     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
845     DatabaseName := RegexObj.Match[4];
846 tony 231 if ServerName = '' then
847     DatabaseName := '/' + DatabaseName;
848 tony 143 end
849     else
850     begin
851 tony 231 {URL type connect string - local loop}
852     RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
853 tony 143 Result := RegexObj.Exec(ConnectString);
854     if Result then
855 tony 231 begin
856 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
857 tony 231 DatabaseName := RegexObj.Match[2];
858     end
859 tony 143 else
860     begin
861 tony 231 RegexObj.Expression := '^([a-zA-Z]:\\.*)';
862 tony 143 Result := RegexObj.Exec(ConnectString);
863     if Result then
864 tony 231 Protocol := Local {Windows with leading drive ID}
865 tony 143 else
866     begin
867 tony 231 RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
868 tony 143 Result := RegexObj.Exec(ConnectString);
869     if Result then
870     begin
871 tony 231 {Legacy TCP Format}
872 tony 143 ServerName := RegexObj.Match[1];
873     if RegexObj.MatchLen[2] > 0 then
874     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
875     DatabaseName := RegexObj.Match[3];
876 tony 231 Protocol := TCP;
877 tony 143 end
878     else
879     begin
880 tony 231 RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
881     Result := RegexObj.Exec(ConnectString);
882     if Result then
883     begin
884     {Netbui}
885     ServerName := RegexObj.Match[1];
886     if RegexObj.MatchLen[2] > 0 then
887     PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
888     DatabaseName := RegexObj.Match[3];
889     Protocol := NamedPipe
890     end
891     else
892     begin
893     Result := true;
894     Protocol := Local; {Assume local}
895     end;
896 tony 143 end;
897     end;
898     end;
899     end;
900     finally
901     RegexObj.Free;
902     end;
903     end;
904    
905 tony 315 {$ELSE}
906     {$IF declared(TRegex)}
907     function ExtractConnectString(const CreateSQL: AnsiString;
908     var ConnectString: AnsiString): boolean;
909     var Regex: TRegEx;
910     Match: TMatch;
911 tony 143 begin
912 tony 315 Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
913     {extact database file spec}
914     Match := Regex.Match(CreateSQL);
915     Result := Match.Success and (Match.Groups.Count = 3);
916     if Result then
917     ConnectString := Match.Groups[2].Value;
918 tony 143 end;
919    
920 tony 315 function ParseConnectString(ConnectString: AnsiString; var ServerName,
921     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
922     ): boolean;
923    
924     var Regex: TRegEx;
925     Match: TMatch;
926     begin
927     ServerName := '';
928     DatabaseName := ConnectString;
929     PortNo := '';
930     Protocol := unknownProtocol;
931     {extact database file spec}
932     Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
933     Result := Match.Success and (Match.Groups.Count = 5);
934     if Result then
935     begin
936     {URL type connect string}
937     Protocol := SchemeToProtocol(Match.Groups[1].Value);
938     ServerName := Match.Groups[2].Value;
939     PortNo := Match.Groups[3].Value;
940     DatabaseName := Match.Groups[4].Value;
941     if ServerName = '' then
942     DatabaseName := '/' + DatabaseName;
943     end
944     else
945     begin
946     {URL type connect string - local loop}
947     Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
948     Result := Match.Success and (Match.Groups.Count = 3);
949     if Result then
950     begin
951     Protocol := SchemeToProtocol(Match.Groups[1].Value);
952     DatabaseName := Match.Groups[2].Value;
953     end
954     else
955     begin
956     Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
957     Result := Match.Success;
958     if Result then
959     Protocol := Local {Windows with leading drive ID}
960     else
961     begin
962     Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
963     Result := Match.Success and (Match.Groups.Count = 4);
964     if Result then
965     begin
966     {Legacy TCP Format}
967     ServerName := Match.Groups[1].Value;
968     PortNo := Match.Groups[2].Value;
969     DatabaseName := Match.Groups[3].Value;
970     Protocol := TCP;
971     end
972     else
973     begin
974     Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
975     Result := Match.Success and (Match.Groups.Count = 4);
976     if Result then
977     begin
978     {Netbui}
979     ServerName := Match.Groups[1].Value;
980     PortNo := Match.Groups[2].Value;
981     DatabaseName := Match.Groups[3].Value;
982     Protocol := NamedPipe
983     end
984     else
985     begin
986     Result := true;
987     Protocol := Local; {Assume local}
988     end;
989     end;
990     end;
991     end;
992     end;
993     end;
994 tony 118 {$ELSE}
995 tony 315 {cruder version of above for Delphi < XE. Older versions lack regular expression
996 tony 121 handling.}
997 tony 118 function ExtractConnectString(const CreateSQL: AnsiString;
998     var ConnectString: AnsiString): boolean;
999     var i: integer;
1000     begin
1001     Result := false;
1002     i := Pos('''',CreateSQL);
1003     if i > 0 then
1004     begin
1005     ConnectString := CreateSQL;
1006     delete(ConnectString,1,i);
1007     i := Pos('''',ConnectString);
1008     if i > 0 then
1009     begin
1010     delete(ConnectString,i,Length(ConnectString)-i+1);
1011     Result := true;
1012     end;
1013     end;
1014     end;
1015 tony 143
1016     function ParseConnectString(ConnectString: AnsiString;
1017     var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1018     var PortNo: AnsiString): boolean;
1019     begin
1020     Result := false;
1021     end;
1022    
1023 tony 315 {$IFEND}
1024     {$IFEND}
1025 tony 117
1026 tony 315 function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1027     var ServerName,
1028     DatabaseName: AnsiString;
1029     PortNo: AnsiString;
1030     begin
1031     if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1032     Result := unknownProtocol;
1033     end;
1034    
1035 tony 143 {Make a connect string in format appropriate protocol}
1036    
1037     function MakeConnectString(ServerName, DatabaseName: AnsiString;
1038     Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1039 tony 231
1040     function FormatURL: AnsiString;
1041     begin
1042     if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1043     Result := DatabaseName
1044     else
1045     Result := ServerName + '/' + DatabaseName;
1046     end;
1047    
1048 tony 143 begin
1049 tony 315 if ServerName = '' then ServerName := 'localhost';
1050 tony 143 if PortNo <> '' then
1051     case Protocol of
1052     NamedPipe:
1053     ServerName := ServerName + '@' + PortNo;
1054     Local,
1055     SPX,
1056     xnet: {do nothing};
1057     TCP:
1058     ServerName := ServerName + '/' + PortNo;
1059     else
1060     ServerName := ServerName + ':' + PortNo;
1061     end;
1062    
1063     case Protocol of
1064     TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
1065     SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
1066     NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1067     Local: Result := DatabaseName; {do not localize}
1068 tony 231 inet: Result := 'inet://' + FormatURL; {do not localize}
1069     inet4: Result := 'inet4://' + FormatURL; {do not localize}
1070     inet6: Result := 'inet6://' + FormatURL; {do not localize}
1071     wnet: Result := 'wnet://' + FormatURL; {do not localize}
1072     xnet: Result := 'xnet://' + FormatURL; {do not localize}
1073 tony 143 end;
1074     end;
1075    
1076 tony 117 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1077    
1078 tony 56 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1079 tony 45 begin
1080 tony 311 Value := TrimRight(Value);
1081 tony 45 if (Dialect = 3) and
1082 tony 115 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1083 tony 117 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
1084 tony 45 else
1085     Result := Value
1086     end;
1087    
1088 tony 117 {Replaces unknown characters in a string with underscores}
1089    
1090 tony 56 function Space2Underscore(s: AnsiString): AnsiString;
1091 tony 45 var
1092     k: integer;
1093     begin
1094     Result := s;
1095     for k := 1 to Length(s) do
1096 tony 117 if not (Result[k] in ValidSQLIdentifierChars) then
1097 tony 45 Result[k] := '_';
1098     end;
1099    
1100 tony 117 {Reformats an SQL string with single quotes duplicated.}
1101    
1102 tony 56 function SQLSafeString(const s: AnsiString): AnsiString;
1103 tony 47 begin
1104     Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1105     end;
1106 tony 45
1107 tony 270 { TSQLParamProcessor }
1108    
1109     function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1110     var slNames: TStrings): AnsiString;
1111     var token: TSQLTokens;
1112     iParamSuffix: Integer;
1113     begin
1114     Result := '';
1115     iParamSuffix := 0;
1116    
1117     while not EOF do
1118     begin
1119     token := GetNextToken;
1120     case token of
1121     sqltParam,
1122     sqltQuotedParam:
1123     begin
1124     Result := Result + '?';
1125     slNames.Add(TokenText);
1126     end;
1127    
1128     sqltPlaceHolder:
1129     if GenerateParamNames then
1130     begin
1131     Inc(iParamSuffix);
1132     slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1133     //add pointer to self to mark entry
1134     Result := Result + '?';
1135     end
1136     else
1137     IBError(ibxeSQLParseError, [SParamNameExpected]);
1138    
1139     sqltQuotedString:
1140     Result := Result + '''' + SQLSafeString(TokenText) + '''';
1141    
1142     sqltIdentifierInDoubleQuotes:
1143     Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1144    
1145     sqltComment:
1146     Result := Result + '/*' + TokenText + '*/';
1147    
1148     sqltCommentLine:
1149 tony 287 Result := Result + '--' + TokenText + LineEnding;
1150 tony 270
1151     sqltEOL:
1152     Result := Result + LineEnding;
1153    
1154     else
1155     Result := Result + TokenText;
1156     end;
1157     end;
1158     end;
1159    
1160     function TSQLParamProcessor.GetChar: AnsiChar;
1161     begin
1162     if FIndex <= Length(FInString) then
1163     begin
1164     Result := FInString[FIndex];
1165     Inc(FIndex);
1166     end
1167     else
1168     Result := #0;
1169     end;
1170    
1171     class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1172     GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1173     begin
1174     with self.Create do
1175     try
1176     FInString := sSQL;
1177     FIndex := 1;
1178     Result := DoExecute(GenerateParamNames,slNames);
1179     finally
1180     Free;
1181     end;
1182     end;
1183    
1184 tony 263 { TSQLwithNamedParamsTokeniser }
1185    
1186     procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1187     begin
1188     inherited Assign(source);
1189     if source is TSQLwithNamedParamsTokeniser then
1190     begin
1191     FState := TSQLwithNamedParamsTokeniser(source).FState;
1192     FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1193     end;
1194     end;
1195    
1196     procedure TSQLwithNamedParamsTokeniser.Reset;
1197     begin
1198     inherited Reset;
1199     FState := stInit;
1200     FNested := 0;
1201     end;
1202    
1203     function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1204     ): boolean;
1205     begin
1206     Result := inherited TokenFound(token);
1207     if not Result then Exit;
1208    
1209     case FState of
1210     stInit:
1211     begin
1212     case token of
1213     sqltColon:
1214     begin
1215     FState := stInParam;
1216     ResetQueue(token);
1217     end;
1218    
1219     sqltBegin:
1220     begin
1221     FState := stInBlock;
1222     FNested := 1;
1223     end;
1224    
1225     sqltOpenSquareBracket:
1226     FState := stInArrayDim;
1227    
1228     end;
1229     end;
1230    
1231     stInParam:
1232     begin
1233     case token of
1234     sqltIdentifier:
1235     token := sqltParam;
1236    
1237     sqltIdentifierInDoubleQuotes:
1238     token := sqltQuotedParam;
1239    
1240     else
1241     begin
1242     QueueToken(token);
1243     ReleaseQueue(token);
1244     end;
1245     end;
1246     FState := stInit;
1247     end;
1248    
1249     stInBlock:
1250     begin
1251     case token of
1252     sqltBegin:
1253     Inc(FNested);
1254    
1255     sqltEnd:
1256     begin
1257     Dec(FNested);
1258     if FNested = 0 then
1259     FState := stInit;
1260     end;
1261     end;
1262     end;
1263    
1264     stInArrayDim:
1265     begin
1266     if token = sqltCloseSquareBracket then
1267     FState := stInit;
1268     end;
1269     end;
1270    
1271     Result := (FState <> stInParam);
1272     end;
1273    
1274     { TSQLTokeniser }
1275    
1276     function TSQLTokeniser.GetNext: TSQLTokens;
1277     var C: AnsiChar;
1278     begin
1279     if EOF then
1280     Result := sqltEOF
1281     else
1282     begin
1283     C := GetChar;
1284     case C of
1285     #0:
1286     Result := sqltEOF;
1287     ' ',TAB:
1288     Result := sqltSpace;
1289     '0'..'9':
1290     Result := sqltNumberString;
1291     ';':
1292     Result := sqltSemiColon;
1293     '?':
1294     Result := sqltPlaceholder;
1295     '|':
1296     Result := sqltPipe;
1297     '"':
1298     Result := sqltDoubleQuotes;
1299     '''':
1300     Result := sqltSingleQuotes;
1301     '/':
1302     Result := sqltForwardSlash;
1303 tony 270 '\':
1304     Result := sqltBackslash;
1305 tony 263 '*':
1306     Result := sqltAsterisk;
1307     '(':
1308     Result := sqltOpenBracket;
1309     ')':
1310     Result := sqltCloseBracket;
1311     ':':
1312     Result := sqltColon;
1313     ',':
1314     Result := sqltComma;
1315     '.':
1316     Result := sqltPeriod;
1317     '=':
1318     Result := sqltEquals;
1319     '[':
1320     Result := sqltOpenSquareBracket;
1321     ']':
1322     Result := sqltCloseSquareBracket;
1323 tony 287 '-':
1324     Result := sqltMinus;
1325 tony 263 '<':
1326     Result := sqltLT;
1327     '>':
1328     Result := sqltGT;
1329     CR:
1330     Result := sqltCR;
1331     LF:
1332     Result := sqltEOL;
1333     else
1334     if C in ValidSQLIdentifierChars then
1335     Result := sqltIdentifier
1336     else
1337     Result := sqltOtherCharacter;
1338     end;
1339     FLastChar := C
1340     end;
1341     FNextToken := Result;
1342     end;
1343    
1344     procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1345     begin
1346     if FQFirst = FQLast then
1347     IBError(ibxeTokenQueueUnderflow,[]);
1348     token := FTokenQueue[FQFirst].token;
1349     FString := FTokenQueue[FQFirst].text;
1350     Inc(FQFirst);
1351     if FQFirst = FQLast then
1352     FQueueState := tsHold;
1353     end;
1354    
1355     procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1356     begin
1357     FString := source.FString;
1358     FNextToken := source.FNextToken;
1359     FTokenQueue := source.FTokenQueue;
1360     FQueueState := source.FQueueState;
1361     FQFirst := source.FQFirst;
1362     FQLast := source.FQLast;
1363     end;
1364    
1365     function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1366     begin
1367     Result := (FState = stDefault);
1368     if Result and (token = sqltIdentifier) then
1369     FindReservedWord(FString,token);
1370     end;
1371    
1372     procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1373     begin
1374     if FQLast > TokenQueueMaxSize then
1375     IBError(ibxeTokenQueueOverflow,[]);
1376     FTokenQueue[FQLast].token := token;
1377     FTokenQueue[FQLast].text := text;
1378     Inc(FQLast);
1379     end;
1380    
1381     procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1382     begin
1383     QueueToken(token,TokenText);
1384     end;
1385    
1386     procedure TSQLTokeniser.ResetQueue;
1387     begin
1388     FQFirst := 0;
1389     FQLast := 0;
1390     FQueueState := tsHold;
1391     end;
1392    
1393     procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1394     begin
1395     ResetQueue;
1396     QueueToken(token,text);
1397     end;
1398    
1399     procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1400     begin
1401     ResetQueue;
1402     QueueToken(token);
1403     end;
1404    
1405     procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1406     begin
1407     FQueueState := tsRelease;
1408     PopQueue(token);
1409     end;
1410    
1411     procedure TSQLTokeniser.ReleaseQueue;
1412     begin
1413     FQueueState := tsRelease;
1414     end;
1415    
1416     function TSQLTokeniser.GetQueuedText: AnsiString;
1417     var i: integer;
1418     begin
1419     Result := '';
1420     for i := FQFirst to FQLast do
1421     Result := Result + FTokenQueue[i].text;
1422     end;
1423    
1424     procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1425     begin
1426     FString := text;
1427     end;
1428    
1429     constructor TSQLTokeniser.Create;
1430     begin
1431     inherited Create;
1432     Reset;
1433     end;
1434    
1435     destructor TSQLTokeniser.Destroy;
1436     begin
1437     Reset;
1438     inherited Destroy;
1439     end;
1440    
1441     procedure TSQLTokeniser.Reset;
1442     begin
1443     FNextToken := sqltInit;
1444     FState := stDefault;
1445     FString := '';
1446     FEOF := false;
1447     ResetQueue;
1448     end;
1449    
1450     function TSQLTokeniser.GetNextToken: TSQLTokens;
1451     begin
1452     if FQueueState = tsRelease then
1453     repeat
1454     PopQueue(Result);
1455     FEOF := Result = sqltEOF;
1456     if TokenFound(Result) then
1457     Exit;
1458     until FQueueState <> tsRelease;
1459    
1460     Result := InternalGetNextToken;
1461     end;
1462    
1463     {a simple lookahead one algorithm to extra the next symbol}
1464    
1465     function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1466     var C: AnsiChar;
1467     begin
1468     Result := sqltEOF;
1469    
1470     if FNextToken = sqltInit then
1471     GetNext;
1472    
1473     repeat
1474     Result := FNextToken;
1475     C := FLastChar;
1476     GetNext;
1477    
1478     if FSkipNext then
1479     begin
1480     FSkipNext := false;
1481     continue;
1482     end;
1483    
1484     case FState of
1485     stInComment:
1486     begin
1487     if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1488     begin
1489     FState := stDefault;
1490     Result := sqltComment;
1491     GetNext;
1492     end
1493     else
1494     FString := FString + C;
1495     end;
1496    
1497     stInCommentLine:
1498     begin
1499     case Result of
1500     sqltEOL:
1501     begin
1502     FState := stDefault;
1503     Result := sqltCommentLine;
1504     end;
1505    
1506     sqltCR: {ignore};
1507    
1508     else
1509     FString := FString + C;
1510     end;
1511     end;
1512    
1513     stSingleQuoted:
1514     begin
1515     if (Result = sqltSingleQuotes) then
1516     begin
1517     if (FNextToken = sqltSingleQuotes) then
1518     begin
1519     FSkipNext := true;
1520     FString := FString + C;
1521     end
1522     else
1523     begin
1524     Result := sqltQuotedString;
1525     FState := stDefault;
1526     end;
1527     end
1528     else
1529     FString := FString + C;
1530     end;
1531    
1532     stDoubleQuoted:
1533     begin
1534     if (Result = sqltDoubleQuotes) then
1535     begin
1536     if (FNextToken = sqltDoubleQuotes) then
1537     begin
1538     FSkipNext := true;
1539     FString := FString + C;
1540     end
1541     else
1542     begin
1543     Result := sqltIdentifierInDoubleQuotes;
1544     FState := stDefault;
1545     end;
1546     end
1547     else
1548     FString := FString + C;
1549     end;
1550    
1551     stInIdentifier:
1552     begin
1553     FString := FString + C;
1554     Result := sqltIdentifier;
1555     if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1556     FState := stDefault
1557     end;
1558    
1559     stInNumeric:
1560     begin
1561     FString := FString + C;
1562     if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1563     begin
1564     {malformed decimal}
1565     FState := stInIdentifier;
1566     Result := sqltIdentifier
1567     end
1568     else
1569     begin
1570     if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1571     FState := stDefault;
1572     Result := sqltNumberString;
1573     end;
1574     end;
1575    
1576     else {stDefault}
1577     begin
1578     FString := C;
1579     case Result of
1580    
1581     sqltPipe:
1582     if FNextToken = sqltPipe then
1583     begin
1584     Result := sqltConcatSymbol;
1585     FString := C + FLastChar;
1586     GetNext;
1587     end;
1588    
1589     sqltForwardSlash:
1590     begin
1591     if FNextToken = sqltAsterisk then
1592     begin
1593     FString := '';
1594     GetNext;
1595     FState := stInComment;
1596     end
1597 tony 287 end;
1598    
1599     sqltMinus:
1600     begin
1601     if FNextToken = sqltMinus then
1602 tony 263 begin
1603     FString := '';
1604     GetNext;
1605     FState := stInCommentLine;
1606     end;
1607     end;
1608    
1609     sqltSingleQuotes:
1610     begin
1611     FString := '';
1612     FState := stSingleQuoted;
1613     end;
1614    
1615     sqltDoubleQuotes:
1616     begin
1617     FString := '';
1618     FState := stDoubleQuoted;
1619     end;
1620    
1621     sqltIdentifier:
1622 tony 265 if FNextToken in [sqltIdentifier,sqltNumberString] then
1623 tony 263 FState := stInIdentifier;
1624    
1625     sqltNumberString:
1626     if FNextToken in [sqltNumberString,sqltPeriod] then
1627     FState := stInNumeric;
1628     end;
1629     end;
1630     end;
1631    
1632     // writeln(FString);
1633     FEOF := Result = sqltEOF;
1634     until TokenFound(Result) or EOF;
1635     end;
1636    
1637 tony 315 function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1638     var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1639     {$IF declared(TFormatSettings)}
1640     begin
1641     {$IF declared(DefaultFormatSettings)}
1642     Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1643     {$ELSE}
1644     {$IF declared(FormatSettings)}
1645     Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1646     {$IFEND} {$IFEND}
1647     end;
1648    
1649     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1650     var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1651     {$IFEND}
1652     const
1653     whitespacechars = [' ',#$09,#$0A,#$0D];
1654     var i,j,l: integer;
1655     aTime: TDateTime;
1656     DMs: longint;
1657     begin
1658     Result := false;
1659     aTimezone := '';
1660     if aDateTimeStr <> '' then
1661     {$if declared(TFormatSettings)}
1662     with aFormatSettings do
1663     {$IFEND}
1664     begin
1665     aDateTime := 0;
1666     {Parse to get time zone info}
1667     i := 1;
1668     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1669     if not TimeOnly then
1670     begin
1671     {decode date}
1672     j := i;
1673     while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1674     if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1675     i := j; {otherwise start again i.e. assume time only}
1676     end;
1677    
1678     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1679     {decode time}
1680     j := i;
1681     while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1682     Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1683     if not Result then Exit;
1684     aDateTime := aDateTime + aTime;
1685     i := j;
1686    
1687     {is there a factional second part}
1688     if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1689     begin
1690     inc(i);
1691     inc(j);
1692     while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1693     if j > i then
1694     begin
1695     l := j-i;
1696     if l > 4 then l := 4;
1697     Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1698     if not Result then Exit;
1699    
1700     {adjust for number of significant digits}
1701     case l of
1702     3: DMs := DMs * 10;
1703     2: DMs := DMs * 100;
1704     1: DMs := DMs * 1000;
1705     end;
1706     aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1707     end;
1708     end;
1709     i := j;
1710    
1711     while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1712     {decode time zone}
1713     if i < length(aDateTimeStr) then
1714     begin
1715     j := i;
1716     while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1717     aTimezone := system.copy(aDateTimeStr,i,j-i);
1718     end;
1719     Result := true;
1720     end
1721     end;
1722    
1723     {The following is similar to FPC DecodeTime except that the Firebird standard
1724     decimilliseconds is used instead of milliseconds for fractional seconds}
1725    
1726     procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1727     var DeciMillisecond: cardinal);
1728     var D : Double;
1729     l : cardinal;
1730     begin
1731     {conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1732     D := aTime * MSecsPerDay *10;
1733     if D < 0 then
1734     D := D - 0.5
1735     else
1736     D := D + 0.5;
1737     {rest hacked from FPC DecodeTIme}
1738     l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1739     Hour := l div 36000000;
1740     l := l mod 36000000;
1741     Minute := l div 600000;
1742     l := l mod 600000;
1743     Second := l div 10000;
1744     DeciMillisecond := l mod 10000;
1745     end;
1746    
1747     {The following is similar to FPC EncodeTime except that the Firebird standard
1748     decimilliseconds is used instead of milliseconds for fractional seconds}
1749    
1750     function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1751     const DMSecsPerDay = MSecsPerDay*10;
1752     var DMs: cardinal;
1753     D: Double;
1754     begin
1755     if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1756     begin
1757     DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1758     D := DMs/DMSecsPerDay;
1759     Result:=TDateTime(d)
1760     end
1761     else
1762     IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1763     end;
1764    
1765     {The following is similar to FPC FormatDateTime except that it additionally
1766     allows the timstamp to have a fractional seconds component with a resolution
1767     of four decimal places. This is appended to the result for FormatDateTime
1768     if the format string contains a "zzzz' string.}
1769    
1770     function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1771     var Hour, Minute, Second: word;
1772     DeciMillisecond: cardinal;
1773     begin
1774     if Pos('zzzz',fmt) > 0 then
1775     begin
1776     FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1777     fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1778     end;
1779     Result := FormatDateTime(fmt,aDateTime);
1780     end;
1781    
1782     function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1783     begin
1784     if EffectiveTimeOffsetMins > 0 then
1785     Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1786     else
1787     Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1788     end;
1789    
1790     function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1791     var i: integer;
1792     begin
1793     Result := false;
1794     TZOffset := Trim(TZOffset);
1795     for i := 1 to Length(TZOffset) do
1796     if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1797    
1798     Result := true;
1799     i := Pos(':',TZOffset);
1800     if i > 0 then
1801     dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1802     else
1803     dstOffset := StrToInt(TZOffset) * 60;
1804     end;
1805    
1806     function StripLeadingZeros(Value: AnsiString): AnsiString;
1807     var i: Integer;
1808     start: integer;
1809     begin
1810     Result := '';
1811     start := 1;
1812     if (Length(Value) > 0) and (Value[1] = '-') then
1813     begin
1814     Result := '-';
1815     start := 2;
1816     end;
1817     for i := start to Length(Value) do
1818     if Value[i] <> '0' then
1819     begin
1820     Result := Result + system.copy(Value, i, MaxInt);
1821     Exit;
1822     end;
1823     end;
1824    
1825 tony 45 end.