ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
(Generate patch)

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 119 by tony, Mon Jan 22 13:58:18 2018 UTC vs.
Revision 359 by tony, Tue Dec 7 09:37:32 2021 UTC

# Line 34 | Line 34
34   unit IBUtils;
35   {$IFDEF MSWINDOWS}
36   {$DEFINE WINDOWS}
37 – {$IF defined(CompilerVersion) and (CompilerVersion >= 28)}
38 – {Delphi XE7 onwards}}
39 – {$define HASREQEX}
40 – {$IFEND}
37   {$ENDIF}
38  
39   {$IFDEF FPC}
40   {$Mode Delphi}
41   {$codepage UTF8}
46 – {$define HASREQEX}
42   {$ENDIF}
43  
44 + { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45 + { $define HASDELPHIREQEX}
46 + { $IFEND}
47  
48   interface
49  
50 < uses Classes, SysUtils;
50 > uses Classes, SysUtils, IB;
51 >
52 > 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 >  sqltBackslash,
264 >  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 >  sqltMinus,
286 >  sqltConcatSymbol,
287 >  sqltLT,
288 >  sqltGT,
289 >  sqltCR,
290 >  sqltEOL,
291 >  sqltEOF,
292 >  sqltInit
293 >  );
294 >
295 >  TSQLReservedWords = sqltAdd..sqltYear;
296  
297   const
298    CRLF = #13 + #10;
# Line 58 | Line 301 | const
301    TAB  = #9;
302    NULL_TERMINATOR = #0;
303  
304 <  sqlReservedWords: array [0..197] of string = (
304 >  {$IFNDEF FPC}
305 >  LineEnding = CRLF;
306 >  {$ENDIF}
307 >
308 >  {SQL Reserved words in alphabetical order}
309 >
310 >  sqlReservedWords: array [TSQLReservedWords] of string = (
311    'ADD',
312    'ADMIN',
313    'ALL',
# Line 150 | Line 399 | const
399    'INTO',
400    'IS',
401    'JOIN',
402 +  'KEY',
403    'LEADING',
404    'LEFT',
405    'LIKE',
# Line 209 | Line 459 | const
459    'RIGHT',
460    'ROLLBACK',
461    'ROW',
212 –  'ROW_COUNT',
462    'ROWS',
463 +  'ROW_COUNT',
464    'SAVEPOINT',
465    'SCROLL',
466    'SECOND',
# Line 222 | Line 472 | const
472    'SOME',
473    'SQLCODE',
474    'SQLSTATE',
225 –  'SQLSTATE',
475    'START',
476    'STDDEV_POP',
477    'STDDEV_SAMP',
# Line 259 | Line 508 | const
508    'YEAR'
509    );
510  
511 + 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 +    function ReadCharacters(NumOfChars: integer): AnsiString;
562 +
563 +    {Token stack}
564 +    procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
565 +    procedure QueueToken(token: TSQLTokens); overload;
566 +    procedure ResetQueue; overload;
567 +    procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
568 +    procedure ResetQueue(token: TSQLTokens); overload;
569 +    procedure ReleaseQueue(var token: TSQLTokens); overload;
570 +    procedure ReleaseQueue; overload;
571 +    function GetQueuedText: AnsiString;
572 +    procedure SetTokenText(text: AnsiString);
573 +
574 +  public
575 +    const
576 +        DefaultTerminator = ';';
577 +  public
578 +    constructor Create;
579 +    destructor Destroy; override;
580 +    function GetNextToken: TSQLTokens;
581 +    property EOF: boolean read FEOF;
582 +    property TokenText: AnsiString read FString;
583 +  end;
584 +
585 +  { TSQLwithNamedParamsTokeniser }
586 +
587 +  TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
588 +  private
589 +    type
590 +      TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
591 +  private
592 +    FState: TSQLState;
593 +    FNested: integer;
594 +  protected
595 +    procedure Assign(source: TSQLTokeniser); override;
596 +    procedure Reset; override;
597 +    function TokenFound(var token: TSQLTokens): boolean; override;
598 +  end;
599 +
600 +    { TSQLParamProcessor }
601 +
602 +  TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
603 +  private
604 +  const
605 +    sIBXParam = 'IBXParam';  {do not localize}
606 +  private
607 +    FInString: AnsiString;
608 +    FIndex: integer;
609 +    function DoExecute(GenerateParamNames: boolean;
610 +        var slNames: TStrings): AnsiString;
611 +  protected
612 +    function GetChar: AnsiChar; override;
613 +  public
614 +    class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
615 +        var slNames: TStrings): AnsiString;
616 +  end;
617 +
618 +
619   function Max(n1, n2: Integer): Integer;
620   function Min(n1, n2: Integer): Integer;
621   function RandomString(iLength: Integer): AnsiString;
622   function RandomInteger(iLow, iHigh: Integer): Integer;
623   function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
624   function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
625 + function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
626 + function IsReservedWord(w: AnsiString): boolean;
627   function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
628   function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
629   function Space2Underscore(s: AnsiString): AnsiString;
630   function SQLSafeString(const s: AnsiString): AnsiString;
631   function IsSQLIdentifier(Value: AnsiString): boolean;
632   function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
633 + function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
634 +              PortNo: AnsiString = ''): AnsiString;
635 + function ParseConnectString(ConnectString: AnsiString;
636 +              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
637 +              var PortNo: AnsiString): boolean;
638 + function GetProtocol(ConnectString: AnsiString): TProtocolAll;
639 +
640 + {$IF declared(TFormatSettings)}
641 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
642 +              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
643 + {$IFEND}
644 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
645 +              var aTimezone: AnsiString; TimeOnly: boolean=false): boolean;  overload;
646 + procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
647 + function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
648 + function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
649 + function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
650 + function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
651 + function StripLeadingZeros(Value: AnsiString): AnsiString;
652 + function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
653 + function NumericToDouble(aValue: Int64; aScale: integer): double;
654 +
655  
656   implementation
657  
658 < {$IFDEF HASREQEX}
659 < uses RegExpr;
660 < {$ENDIF}
658 > uses FBMessages, Math
659 >
660 > {$IFDEF FPC}
661 > ,RegExpr
662 > {$ELSE}
663 > {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
664 > , RegularExpressions
665 > {$IFEND}
666 > {$ENDIF};
667 >
668  
669   function Max(n1, n2: Integer): Integer;
670   begin
# Line 340 | Line 728 | begin
728    Result := Value;
729   end;
730  
731 + {Returns true if "w" is a Firebird SQL reserved word, and the
732 + corresponding TSQLTokens value.}
733 +
734 + function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
735 + var i: TSQLTokens;
736 + begin
737 +   Result := true;
738 +   w := AnsiUpperCase(Trim(w));
739 +   for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
740 +   begin
741 +       if w = sqlReservedWords[i] then
742 +       begin
743 +         token := i;
744 +         Exit;
745 +       end;
746 +       if w <  sqlReservedWords[i] then
747 +         break;
748 +   end;
749 +   Result := false;
750 + end;
751 +
752   {Returns true if "w" is a Firebird SQL reserved word}
753  
754   function IsReservedWord(w: AnsiString): boolean;
755 < var i: integer;
755 > var token: TSQLTokens;
756   begin
757 <     Result := true;
349 <     for i := 0 to Length(sqlReservedWords) - 1 do
350 <         if w = sqlReservedWords[i] then
351 <            Exit;
352 <     Result := false;
757 >  Result := FindReservedWord(w,token);
758   end;
759  
760   {Format an SQL Identifier according to SQL Dialect}
761  
762   function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
763   begin
764 +  Value := TrimRight(Value);
765    if Dialect = 1 then
766 <    Value := AnsiUpperCase(Trim(Value))
766 >    Value := AnsiUpperCase(Value)
767    else
768      Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
769    Result := Value;
# Line 377 | Line 783 | begin
783    Result := true;
784   end;
785  
786 + function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
787 + begin
788 +  scheme := AnsiUpperCase(scheme);
789 +  if scheme = 'INET' then
790 +    Result := inet
791 +  else
792 +  if scheme = 'INET4' then
793 +    Result := inet4
794 +  else
795 +  if scheme = 'INET6' then
796 +    Result := inet6
797 +  else
798 +  if scheme = 'XNET' then
799 +    Result := xnet
800 +  else
801 +  if scheme = 'WNET' then
802 +    Result := wnet
803 + end;
804 +
805   {Extracts the Database Connect string from a Create Database Statement}
806  
807 < {$IFDEF HASREQEX}
807 > {$IF declared(TRegexpr)}
808   function ExtractConnectString(const CreateSQL: AnsiString;
809    var ConnectString: AnsiString): boolean;
810   var RegexObj: TRegExpr;
# Line 392 | Line 817 | begin
817      RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
818      Result := RegexObj.Exec(CreateSQL);
819      if Result then
820 <      ConnectString := system.copy(CreateSQL,RegexObj.MatchPos[2],RegexObj.MatchLen[2]);
820 >      ConnectString := RegexObj.Match[2];
821 >  finally
822 >    RegexObj.Free;
823 >  end;
824 > end;
825 >
826 > function ParseConnectString(ConnectString: AnsiString; var ServerName,
827 >  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
828 >  ): boolean;
829 >
830 > var RegexObj: TRegExpr;
831 > begin
832 >  ServerName := '';
833 >  DatabaseName := ConnectString;
834 >  PortNo := '';
835 >  Protocol := unknownProtocol;
836 >  RegexObj := TRegExpr.Create;
837 >  try
838 >    {extact database file spec}
839 >    RegexObj.ModifierG := false; {turn off greedy matches}
840 >    RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
841 >    Result := RegexObj.Exec(ConnectString);
842 >    if Result then
843 >    begin
844 >      {URL type connect string}
845 >      Protocol := SchemeToProtocol(RegexObj.Match[1]);
846 >      ServerName := RegexObj.Match[2];
847 >      if RegexObj.MatchLen[3] > 0 then
848 >        PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
849 >      DatabaseName := RegexObj.Match[4];
850 >      if ServerName = '' then
851 >        DatabaseName := '/' + DatabaseName;
852 >    end
853 >    else
854 >    begin
855 >      {URL type connect string - local loop}
856 >      RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
857 >      Result := RegexObj.Exec(ConnectString);
858 >      if Result then
859 >      begin
860 >        Protocol := SchemeToProtocol(RegexObj.Match[1]);
861 >        DatabaseName := RegexObj.Match[2];
862 >      end
863 >      else
864 >      begin
865 >        RegexObj.Expression := '^([a-zA-Z]:\\.*)';
866 >        Result := RegexObj.Exec(ConnectString);
867 >        if Result then
868 >          Protocol := Local {Windows with leading drive ID}
869 >        else
870 >        begin
871 >          RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
872 >          Result := RegexObj.Exec(ConnectString);
873 >          if Result then
874 >          begin
875 >            {Legacy TCP Format}
876 >            ServerName := RegexObj.Match[1];
877 >            if RegexObj.MatchLen[2] > 0 then
878 >              PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
879 >            DatabaseName := RegexObj.Match[3];
880 >            Protocol := TCP;
881 >          end
882 >          else
883 >          begin
884 >            RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
885 >            Result := RegexObj.Exec(ConnectString);
886 >            if Result then
887 >            begin
888 >              {Netbui}
889 >              ServerName := RegexObj.Match[1];
890 >              if RegexObj.MatchLen[2] > 0 then
891 >                PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
892 >              DatabaseName := RegexObj.Match[3];
893 >              Protocol := NamedPipe
894 >            end
895 >            else
896 >            begin
897 >              Result := true;
898 >              Protocol := Local; {Assume local}
899 >            end;
900 >          end;
901 >        end;
902 >      end;
903 >    end;
904    finally
905      RegexObj.Free;
906    end;
907   end;
908 +
909   {$ELSE}
910 < {cruder version of above for old versions of Delphi}
910 > {$IF declared(TRegex)}
911 > function ExtractConnectString(const CreateSQL: AnsiString;
912 >  var ConnectString: AnsiString): boolean;
913 > var Regex: TRegEx;
914 >    Match: TMatch;
915 > begin
916 >  Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
917 >  {extact database file spec}
918 >  Match := Regex.Match(CreateSQL);
919 >  Result := Match.Success and (Match.Groups.Count = 3);
920 >  if Result then
921 >    ConnectString := Match.Groups[2].Value;
922 > end;
923 >
924 > function ParseConnectString(ConnectString: AnsiString; var ServerName,
925 >  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
926 >  ): boolean;
927 >
928 > var Regex: TRegEx;
929 >    Match: TMatch;
930 > begin
931 >  ServerName := '';
932 >  DatabaseName := ConnectString;
933 >  PortNo := '';
934 >  Protocol := unknownProtocol;
935 >  {extact database file spec}
936 >  Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
937 >  Result := Match.Success and (Match.Groups.Count = 5);
938 >  if Result then
939 >  begin
940 >    {URL type connect string}
941 >    Protocol := SchemeToProtocol(Match.Groups[1].Value);
942 >    ServerName := Match.Groups[2].Value;
943 >    PortNo := Match.Groups[3].Value;
944 >    DatabaseName := Match.Groups[4].Value;
945 >    if ServerName = '' then
946 >      DatabaseName := '/' + DatabaseName;
947 >  end
948 >  else
949 >  begin
950 >    {URL type connect string - local loop}
951 >    Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
952 >    Result := Match.Success and (Match.Groups.Count = 3);
953 >    if Result then
954 >    begin
955 >      Protocol := SchemeToProtocol(Match.Groups[1].Value);
956 >      DatabaseName := Match.Groups[2].Value;
957 >    end
958 >    else
959 >    begin
960 >      Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
961 >      Result := Match.Success;
962 >      if Result then
963 >        Protocol := Local {Windows with leading drive ID}
964 >      else
965 >      begin
966 >        Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
967 >        Result := Match.Success and (Match.Groups.Count = 4);
968 >        if Result then
969 >        begin
970 >          {Legacy TCP Format}
971 >          ServerName := Match.Groups[1].Value;
972 >          PortNo := Match.Groups[2].Value;
973 >          DatabaseName := Match.Groups[3].Value;
974 >          Protocol := TCP;
975 >        end
976 >        else
977 >        begin
978 >          Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
979 >          Result := Match.Success and (Match.Groups.Count = 4);
980 >          if Result then
981 >          begin
982 >            {Netbui}
983 >            ServerName := Match.Groups[1].Value;
984 >            PortNo := Match.Groups[2].Value;
985 >            DatabaseName := Match.Groups[3].Value;
986 >            Protocol := NamedPipe
987 >          end
988 >          else
989 >          begin
990 >            Result := true;
991 >            Protocol := Local; {Assume local}
992 >          end;
993 >        end;
994 >      end;
995 >    end;
996 >  end;
997 > end;
998 > {$ELSE}
999 > {cruder version of above for Delphi < XE. Older versions lack regular expression
1000 > handling.}
1001   function ExtractConnectString(const CreateSQL: AnsiString;
1002    var ConnectString: AnsiString): boolean;
1003   var i: integer;
# Line 417 | Line 1016 | begin
1016      end;
1017    end;
1018   end;
1019 < {$ENDIF}
1019 >
1020 > function ParseConnectString(ConnectString: AnsiString;
1021 >              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1022 >              var PortNo: AnsiString): boolean;
1023 > begin
1024 >  Result := false;
1025 > end;
1026 >
1027 > {$IFEND}
1028 > {$IFEND}
1029 >
1030 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1031 > var ServerName,
1032 >    DatabaseName: AnsiString;
1033 >    PortNo: AnsiString;
1034 > begin
1035 >  if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1036 >    Result := unknownProtocol;
1037 > end;
1038 >
1039 > {Make a connect string in format appropriate protocol}
1040 >
1041 > function MakeConnectString(ServerName, DatabaseName: AnsiString;
1042 >  Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1043 >
1044 >  function FormatURL: AnsiString;
1045 >  begin
1046 >    if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1047 >      Result := DatabaseName
1048 >    else
1049 >      Result := ServerName + '/' + DatabaseName;
1050 >  end;
1051 >
1052 > begin
1053 >  if ServerName = '' then ServerName := 'localhost';
1054 >  if PortNo <> '' then
1055 >    case Protocol of
1056 >    NamedPipe:
1057 >      ServerName := ServerName + '@' + PortNo;
1058 >    Local,
1059 >    SPX,
1060 >    xnet: {do nothing};
1061 >    TCP:
1062 >      ServerName := ServerName + '/' + PortNo;
1063 >    else
1064 >      ServerName := ServerName + ':' + PortNo;
1065 >    end;
1066 >
1067 >  case Protocol of
1068 >    TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
1069 >    SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
1070 >    NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1071 >    Local:      Result := DatabaseName; {do not localize}
1072 >    inet:       Result := 'inet://' + FormatURL; {do not localize}
1073 >    inet4:       Result := 'inet4://' + FormatURL; {do not localize}
1074 >    inet6:       Result := 'inet6://' + FormatURL; {do not localize}
1075 >    wnet:       Result := 'wnet://' + FormatURL; {do not localize}
1076 >    xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
1077 >  end;
1078 > end;
1079  
1080   {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1081  
1082   function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1083   begin
1084 +  Value := TrimRight(Value);
1085    if (Dialect = 3) and
1086      (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1087       Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
# Line 449 | Line 1108 | begin
1108    Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1109   end;
1110  
1111 + { TSQLParamProcessor }
1112 +
1113 + function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1114 +  var slNames: TStrings): AnsiString;
1115 + var token: TSQLTokens;
1116 +    iParamSuffix: Integer;
1117 + begin
1118 +  Result := '';
1119 +  iParamSuffix := 0;
1120 +
1121 +  while not EOF do
1122 +  begin
1123 +    token := GetNextToken;
1124 +    case token of
1125 +    sqltParam,
1126 +    sqltQuotedParam:
1127 +      begin
1128 +        Result := Result + '?';
1129 +        slNames.Add(TokenText);
1130 +      end;
1131 +
1132 +    sqltPlaceHolder:
1133 +      if GenerateParamNames then
1134 +      begin
1135 +        Inc(iParamSuffix);
1136 +        slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1137 +                                            //add pointer to self to mark entry
1138 +        Result := Result + '?';
1139 +      end
1140 +      else
1141 +        IBError(ibxeSQLParseError, [SParamNameExpected]);
1142 +
1143 +    sqltQuotedString:
1144 +      Result := Result + '''' + SQLSafeString(TokenText) + '''';
1145 +
1146 +    sqltIdentifierInDoubleQuotes:
1147 +      Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1148 +
1149 +    sqltComment:
1150 +      Result := Result + '/*' + TokenText + '*/';
1151 +
1152 +    sqltCommentLine:
1153 +      Result := Result + '--' + TokenText + LineEnding;
1154 +
1155 +    sqltEOL:
1156 +      Result := Result + LineEnding;
1157 +
1158 +    else
1159 +      Result := Result + TokenText;
1160 +    end;
1161 +  end;
1162 + end;
1163 +
1164 + function TSQLParamProcessor.GetChar: AnsiChar;
1165 + begin
1166 +  if FIndex <= Length(FInString) then
1167 +  begin
1168 +    Result := FInString[FIndex];
1169 +    Inc(FIndex);
1170 +  end
1171 +  else
1172 +    Result := #0;
1173 + end;
1174 +
1175 + class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1176 +  GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1177 + begin
1178 +  with self.Create do
1179 +  try
1180 +    FInString := sSQL;
1181 +    FIndex := 1;
1182 +    Result := DoExecute(GenerateParamNames,slNames);
1183 +  finally
1184 +    Free;
1185 +  end;
1186 + end;
1187 +
1188 + { TSQLwithNamedParamsTokeniser }
1189 +
1190 + procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1191 + begin
1192 +  inherited Assign(source);
1193 +  if source is TSQLwithNamedParamsTokeniser then
1194 +  begin
1195 +    FState := TSQLwithNamedParamsTokeniser(source).FState;
1196 +    FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1197 +  end;
1198 + end;
1199 +
1200 + procedure TSQLwithNamedParamsTokeniser.Reset;
1201 + begin
1202 +  inherited Reset;
1203 +  FState := stInit;
1204 +  FNested := 0;
1205 + end;
1206 +
1207 + function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1208 +  ): boolean;
1209 + begin
1210 +  Result := inherited TokenFound(token);
1211 +  if not Result then Exit;
1212 +
1213 +  case FState of
1214 +  stInit:
1215 +    begin
1216 +      case token of
1217 +      sqltColon:
1218 +        begin
1219 +          FState := stInParam;
1220 +          ResetQueue(token);
1221 +        end;
1222 +
1223 +      sqltBegin:
1224 +        begin
1225 +          FState := stInBlock;
1226 +          FNested := 1;
1227 +        end;
1228 +
1229 +      sqltOpenSquareBracket:
1230 +          FState := stInArrayDim;
1231 +
1232 +      end;
1233 +    end;
1234 +
1235 +  stInParam:
1236 +    begin
1237 +      case token of
1238 +      sqltIdentifier:
1239 +        token := sqltParam;
1240 +
1241 +      sqltIdentifierInDoubleQuotes:
1242 +        token := sqltQuotedParam;
1243 +
1244 +      else
1245 +        begin
1246 +          QueueToken(token);
1247 +          ReleaseQueue(token);
1248 +        end;
1249 +      end;
1250 +      FState := stInit;
1251 +    end;
1252 +
1253 +  stInBlock:
1254 +    begin
1255 +      case token of
1256 +      sqltBegin,
1257 +      sqltCase:
1258 +          Inc(FNested);
1259 +
1260 +      sqltEnd:
1261 +        begin
1262 +          Dec(FNested);
1263 +          if FNested = 0 then
1264 +            FState := stInit;
1265 +        end;
1266 +      end;
1267 +    end;
1268 +
1269 +    stInArrayDim:
1270 +      begin
1271 +        if token = sqltCloseSquareBracket then
1272 +            FState := stInit;
1273 +      end;
1274 +    end;
1275 +
1276 +  Result := (FState <> stInParam);
1277 + end;
1278 +
1279 + { TSQLTokeniser }
1280 +
1281 + function TSQLTokeniser.GetNext: TSQLTokens;
1282 + var C: AnsiChar;
1283 + begin
1284 +  if EOF then
1285 +    Result := sqltEOF
1286 +  else
1287 +  begin
1288 +    C := GetChar;
1289 +    case C of
1290 +    #0:
1291 +      Result := sqltEOF;
1292 +    ' ',TAB:
1293 +      Result := sqltSpace;
1294 +    '0'..'9':
1295 +      Result := sqltNumberString;
1296 +    ';':
1297 +      Result := sqltSemiColon;
1298 +    '?':
1299 +      Result := sqltPlaceholder;
1300 +    '|':
1301 +      Result := sqltPipe;
1302 +    '"':
1303 +      Result := sqltDoubleQuotes;
1304 +    '''':
1305 +      Result := sqltSingleQuotes;
1306 +    '/':
1307 +      Result := sqltForwardSlash;
1308 +    '\':
1309 +      Result := sqltBackslash;
1310 +    '*':
1311 +      Result := sqltAsterisk;
1312 +    '(':
1313 +      Result := sqltOpenBracket;
1314 +    ')':
1315 +      Result := sqltCloseBracket;
1316 +    ':':
1317 +      Result := sqltColon;
1318 +    ',':
1319 +      Result := sqltComma;
1320 +    '.':
1321 +      Result := sqltPeriod;
1322 +    '=':
1323 +      Result := sqltEquals;
1324 +    '[':
1325 +      Result := sqltOpenSquareBracket;
1326 +    ']':
1327 +      Result := sqltCloseSquareBracket;
1328 +    '-':
1329 +      Result := sqltMinus;
1330 +    '<':
1331 +      Result := sqltLT;
1332 +    '>':
1333 +      Result := sqltGT;
1334 +    CR:
1335 +      Result := sqltCR;
1336 +    LF:
1337 +      Result := sqltEOL;
1338 +    else
1339 +      if C in ValidSQLIdentifierChars then
1340 +        Result := sqltIdentifier
1341 +      else
1342 +        Result := sqltOtherCharacter;
1343 +    end;
1344 +    FLastChar := C
1345 +  end;
1346 +  FNextToken := Result;
1347 + end;
1348 +
1349 + procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1350 + begin
1351 +  if FQFirst = FQLast then
1352 +    IBError(ibxeTokenQueueUnderflow,[]);
1353 +  token := FTokenQueue[FQFirst].token;
1354 +  FString := FTokenQueue[FQFirst].text;
1355 +  Inc(FQFirst);
1356 +  if FQFirst = FQLast then
1357 +    FQueueState := tsHold;
1358 + end;
1359 +
1360 + procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1361 + begin
1362 +  FString := source.FString;
1363 +  FNextToken := source.FNextToken;
1364 +  FTokenQueue := source.FTokenQueue;
1365 +  FQueueState := source.FQueueState;
1366 +  FQFirst := source.FQFirst;
1367 +  FQLast := source.FQLast;
1368 + end;
1369 +
1370 + function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1371 + begin
1372 +  Result := (FState = stDefault);
1373 +  if Result and (token = sqltIdentifier)  then
1374 +    FindReservedWord(FString,token);
1375 + end;
1376 +
1377 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1378 + begin
1379 +  if FQLast > TokenQueueMaxSize then
1380 +    IBError(ibxeTokenQueueOverflow,[]);
1381 +  FTokenQueue[FQLast].token := token;
1382 +  FTokenQueue[FQLast].text := text;
1383 +  Inc(FQLast);
1384 + end;
1385 +
1386 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1387 + begin
1388 +  QueueToken(token,TokenText);
1389 + end;
1390 +
1391 + procedure TSQLTokeniser.ResetQueue;
1392 + begin
1393 +  FQFirst := 0;
1394 +  FQLast := 0;
1395 +  FQueueState := tsHold;
1396 + end;
1397 +
1398 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1399 + begin
1400 +  ResetQueue;
1401 +  QueueToken(token,text);
1402 + end;
1403 +
1404 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1405 + begin
1406 +  ResetQueue;
1407 +  QueueToken(token);
1408 + end;
1409 +
1410 + procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1411 + begin
1412 +  FQueueState := tsRelease;
1413 +  PopQueue(token);
1414 + end;
1415 +
1416 + procedure TSQLTokeniser.ReleaseQueue;
1417 + begin
1418 +  FQueueState := tsRelease;
1419 + end;
1420 +
1421 + function TSQLTokeniser.GetQueuedText: AnsiString;
1422 + var i: integer;
1423 + begin
1424 +  Result := '';
1425 +  for i := FQFirst to FQLast do
1426 +    Result := Result + FTokenQueue[i].text;
1427 + end;
1428 +
1429 + procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1430 + begin
1431 +  FString := text;
1432 + end;
1433 +
1434 + constructor TSQLTokeniser.Create;
1435 + begin
1436 +  inherited Create;
1437 +  Reset;
1438 + end;
1439 +
1440 + destructor TSQLTokeniser.Destroy;
1441 + begin
1442 +  Reset;
1443 +  inherited Destroy;
1444 + end;
1445 +
1446 + procedure TSQLTokeniser.Reset;
1447 + begin
1448 +  FNextToken := sqltInit;
1449 +  FState := stDefault;
1450 +  FString := '';
1451 +  FEOF := false;
1452 +  ResetQueue;
1453 + end;
1454 +
1455 + function TSQLTokeniser.ReadCharacters(NumOfChars: integer): AnsiString;
1456 + var i: integer;
1457 + begin
1458 +  Result := FLastChar;
1459 +  for i := 2 to NumOfChars do
1460 +  begin
1461 +    if GetNext = sqltEOF then break;
1462 +    Result := Result + FLastChar;
1463 +  end;
1464 + end;
1465 +
1466 + function TSQLTokeniser.GetNextToken: TSQLTokens;
1467 + begin
1468 +  if FQueueState = tsRelease then
1469 +  repeat
1470 +    PopQueue(Result);
1471 +    FEOF := Result = sqltEOF;
1472 +    if TokenFound(Result) then
1473 +      Exit;
1474 +  until FQueueState <> tsRelease;
1475 +
1476 +  Result := InternalGetNextToken;
1477 + end;
1478 +
1479 + {a simple lookahead one algorithm to extra the next symbol}
1480 +
1481 + function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1482 + var C: AnsiChar;
1483 + begin
1484 +  Result := sqltEOF;
1485 +
1486 +  if FNextToken = sqltInit then
1487 +    GetNext;
1488 +
1489 +  repeat
1490 +    if FSkipNext then
1491 +    begin
1492 +      FSkipNext := false;
1493 +      GetNext;
1494 +    end;
1495 +
1496 +    Result := FNextToken;
1497 +    C := FLastChar;
1498 +    GetNext;
1499 +
1500 +    if (Result = sqltCR) and (FNextToken = sqltEOL) then
1501 +    begin
1502 +      FSkipNext := true;
1503 +      Result := sqltEOL;
1504 +      C := LF;
1505 +    end;
1506 +
1507 +    case FState of
1508 +    stInComment:
1509 +      begin
1510 +        if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1511 +        begin
1512 +          FState := stDefault;
1513 +          Result := sqltComment;
1514 +          GetNext;
1515 +        end
1516 +        else
1517 +        if Result = sqltEOL then
1518 +          FString := FString + LineEnding
1519 +        else
1520 +          FString := FString + C;
1521 +      end;
1522 +
1523 +    stInCommentLine:
1524 +      begin
1525 +        case Result of
1526 +        sqltEOL:
1527 +          begin
1528 +            FState := stDefault;
1529 +            Result := sqltCommentLine;
1530 +          end;
1531 +
1532 +        else
1533 +          FString := FString + C;
1534 +        end;
1535 +      end;
1536 +
1537 +    stSingleQuoted:
1538 +      begin
1539 +        if (Result = sqltSingleQuotes) then
1540 +        begin
1541 +          if (FNextToken = sqltSingleQuotes) then
1542 +          begin
1543 +            FSkipNext := true;
1544 +            FString := FString + C;
1545 +          end
1546 +          else
1547 +          begin
1548 +            Result := sqltQuotedString;
1549 +            FState := stDefault;
1550 +          end;
1551 +        end
1552 +        else
1553 +        if Result = sqltEOL then
1554 +          FString := FString + LineEnding
1555 +        else
1556 +          FString := FString + C;
1557 +      end;
1558 +
1559 +    stDoubleQuoted:
1560 +      begin
1561 +        if (Result = sqltDoubleQuotes) then
1562 +        begin
1563 +          if (FNextToken = sqltDoubleQuotes) then
1564 +          begin
1565 +            FSkipNext := true;
1566 +            FString := FString + C;
1567 +          end
1568 +          else
1569 +          begin
1570 +            Result := sqltIdentifierInDoubleQuotes;
1571 +            FState := stDefault;
1572 +          end;
1573 +        end
1574 +        else
1575 +        if Result = sqltEOL then
1576 +          FString := FString + LineEnding
1577 +        else
1578 +          FString := FString + C;
1579 +      end;
1580 +
1581 +    stInIdentifier:
1582 +      begin
1583 +        FString := FString + C;
1584 +        Result := sqltIdentifier;
1585 +        if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1586 +          FState := stDefault
1587 +      end;
1588 +
1589 +    stInNumeric:
1590 +      begin
1591 +        FString := FString + C;
1592 +        if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1593 +        begin
1594 +          {malformed decimal}
1595 +          FState := stInIdentifier;
1596 +          Result := sqltIdentifier
1597 +        end
1598 +        else
1599 +        begin
1600 +          if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1601 +            FState := stDefault;
1602 +          Result := sqltNumberString;
1603 +        end;
1604 +      end;
1605 +
1606 +    else {stDefault}
1607 +      begin
1608 +        FString := C;
1609 +        case Result of
1610 +
1611 +        sqltPipe:
1612 +          if FNextToken = sqltPipe then
1613 +          begin
1614 +            Result := sqltConcatSymbol;
1615 +            FString := C + FLastChar;
1616 +            GetNext;
1617 +          end;
1618 +
1619 +        sqltForwardSlash:
1620 +          begin
1621 +            if FNextToken = sqltAsterisk then
1622 +            begin
1623 +              FString := '';
1624 +              GetNext;
1625 +              FState := stInComment;
1626 +            end
1627 +          end;
1628 +
1629 +        sqltMinus:
1630 +          begin
1631 +            if FNextToken = sqltMinus then
1632 +            begin
1633 +              FString := '';
1634 +              GetNext;
1635 +              FState := stInCommentLine;
1636 +            end;
1637 +          end;
1638 +
1639 +        sqltSingleQuotes:
1640 +          begin
1641 +            FString := '';
1642 +            FState := stSingleQuoted;
1643 +          end;
1644 +
1645 +        sqltDoubleQuotes:
1646 +          begin
1647 +            FString := '';
1648 +            FState := stDoubleQuoted;
1649 +          end;
1650 +
1651 +        sqltIdentifier:
1652 +          if FNextToken in [sqltIdentifier,sqltNumberString] then
1653 +            FState := stInIdentifier;
1654 +
1655 +        sqltNumberString:
1656 +          if FNextToken in [sqltNumberString,sqltPeriod] then
1657 +            FState := stInNumeric;
1658 +
1659 +        sqltEOL:
1660 +          FString := LineEnding;
1661 +        end;
1662 +      end;
1663 +    end;
1664 +
1665 + //    writeln(FString);
1666 +    FEOF := Result = sqltEOF;
1667 +  until TokenFound(Result) or EOF;
1668 + end;
1669 +
1670 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1671 +  var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1672 + {$IF declared(TFormatSettings)}
1673 + begin
1674 +    {$IF declared(DefaultFormatSettings)}
1675 +    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1676 +    {$ELSE}
1677 +    {$IF declared(FormatSettings)}
1678 +    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1679 +    {$IFEND} {$IFEND}
1680 + end;
1681 +
1682 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1683 +              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1684 + {$IFEND}
1685 + const
1686 +  whitespacechars = [' ',#$09,#$0A,#$0D];
1687 + var i,j,l: integer;
1688 +    aTime: TDateTime;
1689 +    DMs: longint;
1690 + begin
1691 +  Result := false;
1692 +  aTimezone := '';
1693 +  if aDateTimeStr <> '' then
1694 +  {$if declared(TFormatSettings)}
1695 +  with aFormatSettings do
1696 +  {$IFEND}
1697 +  begin
1698 +    aDateTime := 0;
1699 +    {Parse to get time zone info}
1700 +    i := 1;
1701 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1702 +    if not TimeOnly then
1703 +    begin
1704 +      {decode date}
1705 +      j := i;
1706 +      while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1707 +      if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1708 +        i := j; {otherwise start again i.e. assume time only}
1709 +    end;
1710 +
1711 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1712 +    {decode time}
1713 +    j := i;
1714 +    while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1715 +    Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1716 +    if not Result then Exit;
1717 +    aDateTime := aDateTime + aTime;
1718 +    i := j;
1719 +
1720 +    {is there a factional second part}
1721 +    if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1722 +    begin
1723 +      inc(i);
1724 +      inc(j);
1725 +      while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1726 +      if j > i then
1727 +      begin
1728 +        l := j-i;
1729 +        if l > 4 then l := 4;
1730 +        Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1731 +        if not Result then Exit;
1732 +
1733 +        {adjust for number of significant digits}
1734 +        case l of
1735 +        3:   DMs := DMs * 10;
1736 +        2:   DMs := DMs * 100;
1737 +        1:   DMs := DMs * 1000;
1738 +        end;
1739 +       aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1740 +      end;
1741 +    end;
1742 +    i := j;
1743 +
1744 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1745 +    {decode time zone}
1746 +    if i < length(aDateTimeStr) then
1747 +    begin
1748 +      j := i;
1749 +      while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1750 +      aTimezone := system.copy(aDateTimeStr,i,j-i);
1751 +    end;
1752 +    Result := true;
1753 +  end
1754 + end;
1755 +
1756 + {The following is similar to FPC DecodeTime except that the Firebird standard
1757 + decimilliseconds is used instead of milliseconds for fractional seconds}
1758 +
1759 + procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1760 +  var DeciMillisecond: cardinal);
1761 + var D : Double;
1762 +    l : cardinal;
1763 + begin
1764 +  {conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1765 +  D := aTime * MSecsPerDay *10;
1766 +  if D < 0 then
1767 +    D := D - 0.5
1768 +  else
1769 +    D := D + 0.5;
1770 +  {rest hacked from FPC DecodeTIme}
1771 +  l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1772 +  Hour   := l div 36000000;
1773 +  l := l mod 36000000;
1774 +  Minute := l div 600000;
1775 +  l := l mod 600000;
1776 +  Second := l div 10000;
1777 +  DeciMillisecond := l mod 10000;
1778 + end;
1779 +
1780 + {The following is similar to FPC EncodeTime except that the Firebird standard
1781 + decimilliseconds is used instead of milliseconds for fractional seconds}
1782 +
1783 + function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1784 + const DMSecsPerDay = MSecsPerDay*10;
1785 + var DMs: cardinal;
1786 +    D: Double;
1787 + begin
1788 +  if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1789 +  begin
1790 +    DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1791 +    D := DMs/DMSecsPerDay;
1792 +    Result:=TDateTime(d)
1793 +  end
1794 +  else
1795 +    IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1796 + end;
1797 +
1798 + {The following is similar to FPC FormatDateTime except that it additionally
1799 + allows the timstamp to have a fractional seconds component with a resolution
1800 + of four decimal places. This is appended to the result for FormatDateTime
1801 + if the format string contains a "zzzz' string.}
1802 +
1803 + function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1804 + var Hour, Minute, Second: word;
1805 +    DeciMillisecond: cardinal;
1806 + begin
1807 +  if Pos('zzzz',fmt) > 0 then
1808 +  begin
1809 +    FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1810 +    fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1811 +  end;
1812 +  Result := FormatDateTime(fmt,aDateTime);
1813 + end;
1814 +
1815 + function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1816 + begin
1817 +  if EffectiveTimeOffsetMins > 0 then
1818 +    Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1819 +  else
1820 +    Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1821 + end;
1822 +
1823 + function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1824 + var i: integer;
1825 + begin
1826 +  Result := false;
1827 +  TZOffset := Trim(TZOffset);
1828 +  for i := 1 to Length(TZOffset) do
1829 +    if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1830 +
1831 +  Result := true;
1832 +  i := Pos(':',TZOffset);
1833 +  if i > 0 then
1834 +    dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1835 +  else
1836 +    dstOffset := StrToInt(TZOffset) * 60;
1837 + end;
1838 +
1839 + function StripLeadingZeros(Value: AnsiString): AnsiString;
1840 + var i: Integer;
1841 +    start: integer;
1842 + begin
1843 +  Result := '';
1844 +  start := 1;
1845 +  if (Length(Value) > 0) and (Value[1] = '-') then
1846 +  begin
1847 +    Result := '-';
1848 +    start := 2;
1849 +  end;
1850 +  for i := start to Length(Value) do
1851 +    if Value[i] <> '0' then
1852 +    begin
1853 +      Result := Result + system.copy(Value, i, MaxInt);
1854 +      Exit;
1855 +    end;
1856 + end;
1857 +
1858 + function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
1859 + var i: integer;
1860 +    ds: integer;
1861 +    exponent: integer;
1862 + begin
1863 +  Result := false;
1864 +  ds := 0;
1865 +  exponent := 0;
1866 +  S := Trim(S);
1867 +  Value := 0;
1868 +  scale := 0;
1869 +  if Length(S) = 0 then
1870 +    Exit;
1871 +  {$IF declared(DefaultFormatSettings)}
1872 +  with DefaultFormatSettings do
1873 +  {$ELSE}
1874 +  {$IF declared(FormatSettings)}
1875 +  with FormatSettings do
1876 +  {$IFEND}
1877 +  {$IFEND}
1878 +  begin
1879 +    for i := length(S) downto 1 do
1880 +    begin
1881 +      if S[i] = AnsiChar(DecimalSeparator) then
1882 +      begin
1883 +          if ds <> 0 then Exit; {only one allowed}
1884 +          ds := i;
1885 +          dec(exponent);
1886 +          system.Delete(S,i,1);
1887 +      end
1888 +      else
1889 +      if S[i] in ['+','-'] then
1890 +      begin
1891 +       if (i > 1) and not (S[i-1] in ['e','E']) then
1892 +          Exit; {malformed}
1893 +      end
1894 +      else
1895 +      if S[i] in ['e','E'] then {scientific notation}
1896 +      begin
1897 +        if ds <> 0 then Exit; {not permitted in exponent}
1898 +        if exponent <> 0 then Exit; {only one allowed}
1899 +        exponent := i;
1900 +      end
1901 +      else
1902 +      if not (S[i] in ['0'..'9']) then
1903 +      {Note: ThousandSeparator not allowed by Delphi specs}
1904 +          Exit; {bad character}
1905 +    end;
1906 +
1907 +    if exponent > 0 then
1908 +    begin
1909 +      Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1910 +      if Result then
1911 +      begin
1912 +        {adjust scale for decimal point}
1913 +        if ds <> 0 then
1914 +          Scale := Scale - (exponent - ds);
1915 +        Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1916 +      end;
1917 +    end
1918 +    else
1919 +    begin
1920 +      if ds <> 0 then
1921 +        scale := ds - Length(S) - 1;
1922 +      Result := TryStrToInt64(S,Value);
1923 +    end;
1924 +  end;
1925 + end;
1926 +
1927 + function NumericToDouble(aValue: Int64; aScale: integer): double;
1928 + begin
1929 +  Result := aValue * IntPower(10,aScale)
1930 + end;
1931 +
1932   end.

Diff Legend

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