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

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
Revision 354 by tony, Sat Oct 23 14:32:11 2021 UTC

# Line 32 | Line 32
32   {************************************************************************}
33  
34   unit IBUtils;
35 + {$IFDEF MSWINDOWS}
36 + {$DEFINE WINDOWS}
37 + {$ENDIF}
38  
39   {$IFDEF FPC}
40   {$Mode Delphi}
41   {$codepage UTF8}
42   {$ENDIF}
43  
44 + { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45 + { $define HASDELPHIREQEX}
46 + { $IFEND}
47 +
48   interface
49  
50 < uses
51 < {$IFDEF WINDOWS }
52 <  Windows,
53 < {$ELSE}
54 <  unix,
55 < {$ENDIF}
56 <  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 55 | Line 301 | const
301    TAB  = #9;
302    NULL_TERMINATOR = #0;
303  
304 <  sqlReservedWords: array [0..166] of string = (
305 <  'ADD','ADMIN','ALL','ALTER','AND','ANY','AS','AT','AVG','BEGIN','BETWEEN','BIGINT','BIT_LENGTH','BLOB','BOTH',
306 < 'BY','CASE','CAST','CHAR','CHAR_LENGTH','CHARACTER','CHARACTER_LENGTH','CHECK','CLOSE','COLLATE','COLUMN',
307 < 'COMMIT','CONNECT','CONSTRAINT','COUNT','CREATE','CROSS','CURRENT','CURRENT_CONNECTION','CURRENT_DATE',
308 < 'CURRENT_ROLE','CURRENT_TIME','CURRENT_TIMESTAMP','CURRENT_TRANSACTION','CURRENT_USER','CURSOR','DATE',
309 < 'DAY','DEC','DECIMAL','DECLARE','DEFAULT','DELETE','DISCONNECT','DISTINCT','DOUBLE','DROP','ELSE','END',
310 < 'ESCAPE','EXECUTE','EXISTS','EXTERNAL','EXTRACT','FETCH','FILTER','FLOAT','FOR','FOREIGN','FROM','FULL',
311 < 'FUNCTION','GDSCODE','GLOBAL','GRANT','GROUP','HAVING','HOUR','IN','INDEX','INNER','INSENSITIVE','INSERT',
312 < 'INT','INTEGER','INTO','IS','JOIN','LEADING','LEFT','LIKE','LONG','LOWER','MAX','MAXIMUM_SEGMENT','MERGE',
313 < 'MIN','MINUTE','MONTH','NATIONAL','NATURAL','NCHAR','NO','NOT','NULL','NUMERIC','OCTET_LENGTH','OF','ON',
314 < 'ONLY','OPEN','OR','ORDER','OUTER','PARAMETER','PLAN','POSITION','POST_EVENT','PRECISION','PRIMARY',
315 < 'PROCEDURE','RDB$DB_KEY','REAL','RECORD_VERSION','RECREATE','RECURSIVE','REFERENCES','RELEASE','RETURNING_VALUES',
316 < 'RETURNS','REVOKE','RIGHT','ROLLBACK','ROW_COUNT','ROWS','SAVEPOINT','SECOND','SELECT','SENSITIVE',
317 < 'SET','SIMILAR','SMALLINT','SOME','SQLCODE','SQLSTATE','START','SUM','TABLE','THEN','TIME',
318 < 'TIMESTAMP','TO','TRAILING','TRIGGER','TRIM','UNION','UNIQUE','UPDATE','UPPER','USER','USING',
319 < 'VALUE','VALUES','VARCHAR','VARIABLE','VARYING','VIEW','WHEN','WHERE','WHILE','WITH','YEAR');
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',
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 >  'KEY',
403 >  '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 >  'ROWS',
463 >  '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 >
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 >
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 >    { 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   function Max(n1, n2: Integer): Integer;
619   function Min(n1, n2: Integer): Integer;
620 < function RandomString(iLength: Integer): String;
620 > function RandomString(iLength: Integer): AnsiString;
621   function RandomInteger(iLow, iHigh: Integer): Integer;
622 < function StripString(st: String; CharsToStrip: String): String;
623 < function FormatIdentifier(Dialect: Integer; Value: String): String;
624 < function FormatIdentifierValue(Dialect: Integer; Value: String): String;
625 < function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
626 < function ExtractIdentifier(Dialect: Integer; Value: String): String;
627 < function QuoteIdentifier(Dialect: Integer; Value: String): String;
628 < function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
629 < function Space2Underscore(s: string): string;
622 > function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
623 > function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624 > function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
625 > function IsReservedWord(w: AnsiString): boolean;
626 > 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 > function IsSQLIdentifier(Value: AnsiString): boolean;
631 > function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
632 > 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 >
639 > {$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 > function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
652 > function NumericToDouble(aValue: Int64; aScale: integer): double;
653 >
654  
655   implementation
656  
657 + uses FBMessages, Math
658 +
659 + {$IFDEF FPC}
660 + ,RegExpr
661 + {$ELSE}
662 + {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
663 + , RegularExpressions
664 + {$IFEND}
665 + {$ENDIF};
666 +
667 +
668   function Max(n1, n2: Integer): Integer;
669   begin
670    if (n1 > n2) then
# Line 103 | Line 681 | begin
681      result := n2;
682   end;
683  
684 < function RandomString(iLength: Integer): String;
684 > function RandomString(iLength: Integer): AnsiString;
685   begin
686    result := '';
687    while Length(result) < iLength do
# Line 117 | Line 695 | begin
695    result := Trunc(Random(iHigh - iLow)) + iLow;
696   end;
697  
698 < function StripString(st: String; CharsToStrip: String): String;
698 > function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
699   var
700    i: Integer;
701   begin
# Line 128 | Line 706 | begin
706    end;
707   end;
708  
709 < function FormatIdentifier(Dialect: Integer; Value: String): String;
132 < begin
133 <  Value := Trim(Value);
134 <  if Dialect = 1 then
135 <    Value := AnsiUpperCase(Value)
136 <  else
137 <    if (Value <> '') and (Value[1] = '"') then
138 <      Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
139 <    else
140 <      Value := AnsiUpperCase(Value);
141 <  Result := Value;
142 < end;
709 > {Extracts SQL Identifier typically from a  Dialect 3 encoding}
710  
711 < function FormatIdentifierValue(Dialect: Integer; Value: String): String;
711 > function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
712   begin
713    Value := Trim(Value);
714    if Dialect = 1 then
# Line 160 | Line 727 | begin
727    Result := Value;
728   end;
729  
730 < function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
730 > {Returns true if "w" is a Firebird SQL reserved word, and the
731 > corresponding TSQLTokens value.}
732 >
733 > function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
734 > var i: TSQLTokens;
735   begin
736 <  Value := Trim(Value);
736 >   Result := true;
737 >   w := AnsiUpperCase(Trim(w));
738 >   for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
739 >   begin
740 >       if w = sqlReservedWords[i] then
741 >       begin
742 >         token := i;
743 >         Exit;
744 >       end;
745 >       if w <  sqlReservedWords[i] then
746 >         break;
747 >   end;
748 >   Result := false;
749 > end;
750 >
751 > {Returns true if "w" is a Firebird SQL reserved word}
752 >
753 > function IsReservedWord(w: AnsiString): boolean;
754 > var token: TSQLTokens;
755 > begin
756 >  Result := FindReservedWord(w,token);
757 > end;
758 >
759 > {Format an SQL Identifier according to SQL Dialect}
760 >
761 > function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
762 > begin
763 >  Value := TrimRight(Value);
764    if Dialect = 1 then
765      Value := AnsiUpperCase(Value)
766    else
767 <  begin
768 <    if (Value <> '') and (Value[1] = '"') then
767 >    Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
768 >  Result := Value;
769 > end;
770 >
771 > const
772 >  ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
773 >
774 > {Returns true if the value is a valid SQL Identifier - note lower case accepted}
775 >
776 > function IsSQLIdentifier(Value: AnsiString): boolean;
777 > var i: integer;
778 > begin
779 >  Result := false;
780 >  for i := 1 to Length(Value) do
781 >    if not (Value[i] in ValidSQLIdentifierChars) then Exit;
782 >  Result := true;
783 > end;
784 >
785 > function SchemeToProtocol(scheme: AnsiString): TProtocolAll;
786 > begin
787 >  scheme := AnsiUpperCase(scheme);
788 >  if scheme = 'INET' then
789 >    Result := inet
790 >  else
791 >  if scheme = 'INET4' then
792 >    Result := inet4
793 >  else
794 >  if scheme = 'INET6' then
795 >    Result := inet6
796 >  else
797 >  if scheme = 'XNET' then
798 >    Result := xnet
799 >  else
800 >  if scheme = 'WNET' then
801 >    Result := wnet
802 > end;
803 >
804 > {Extracts the Database Connect string from a Create Database Statement}
805 >
806 > {$IF declared(TRegexpr)}
807 > function ExtractConnectString(const CreateSQL: AnsiString;
808 >  var ConnectString: AnsiString): boolean;
809 > var RegexObj: TRegExpr;
810 > begin
811 >  RegexObj := TRegExpr.Create;
812 >  try
813 >    {extact database file spec}
814 >    RegexObj.ModifierG := false; {turn off greedy matches}
815 >    RegexObj.ModifierI := true; {case insensitive match}
816 >    RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
817 >    Result := RegexObj.Exec(CreateSQL);
818 >    if Result then
819 >      ConnectString := RegexObj.Match[2];
820 >  finally
821 >    RegexObj.Free;
822 >  end;
823 > end;
824 >
825 > function ParseConnectString(ConnectString: AnsiString; var ServerName,
826 >  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
827 >  ): boolean;
828 >
829 > var RegexObj: TRegExpr;
830 > begin
831 >  ServerName := '';
832 >  DatabaseName := ConnectString;
833 >  PortNo := '';
834 >  Protocol := unknownProtocol;
835 >  RegexObj := TRegExpr.Create;
836 >  try
837 >    {extact database file spec}
838 >    RegexObj.ModifierG := false; {turn off greedy matches}
839 >    RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
840 >    Result := RegexObj.Exec(ConnectString);
841 >    if Result then
842      begin
843 <      Delete(Value, 1, 1);
844 <      Delete(Value, Length(Value), 1);
845 <      Value := AnsiUpperCase(StringReplace (Value, '""', '"', [rfReplaceAll]));
843 >      {URL type connect string}
844 >      Protocol := SchemeToProtocol(RegexObj.Match[1]);
845 >      ServerName := RegexObj.Match[2];
846 >      if RegexObj.MatchLen[3] > 0 then
847 >        PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
848 >      DatabaseName := RegexObj.Match[4];
849 >      if ServerName = '' then
850 >        DatabaseName := '/' + DatabaseName;
851      end
852      else
853 <      Value := AnsiUpperCase(Value);
853 >    begin
854 >      {URL type connect string - local loop}
855 >      RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
856 >      Result := RegexObj.Exec(ConnectString);
857 >      if Result then
858 >      begin
859 >        Protocol := SchemeToProtocol(RegexObj.Match[1]);
860 >        DatabaseName := RegexObj.Match[2];
861 >      end
862 >      else
863 >      begin
864 >        RegexObj.Expression := '^([a-zA-Z]:\\.*)';
865 >        Result := RegexObj.Exec(ConnectString);
866 >        if Result then
867 >          Protocol := Local {Windows with leading drive ID}
868 >        else
869 >        begin
870 >          RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
871 >          Result := RegexObj.Exec(ConnectString);
872 >          if Result then
873 >          begin
874 >            {Legacy TCP Format}
875 >            ServerName := RegexObj.Match[1];
876 >            if RegexObj.MatchLen[2] > 0 then
877 >              PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
878 >            DatabaseName := RegexObj.Match[3];
879 >            Protocol := TCP;
880 >          end
881 >          else
882 >          begin
883 >            RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
884 >            Result := RegexObj.Exec(ConnectString);
885 >            if Result then
886 >            begin
887 >              {Netbui}
888 >              ServerName := RegexObj.Match[1];
889 >              if RegexObj.MatchLen[2] > 0 then
890 >                PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
891 >              DatabaseName := RegexObj.Match[3];
892 >              Protocol := NamedPipe
893 >            end
894 >            else
895 >            begin
896 >              Result := true;
897 >              Protocol := Local; {Assume local}
898 >            end;
899 >          end;
900 >        end;
901 >      end;
902 >    end;
903 >  finally
904 >    RegexObj.Free;
905    end;
179 –  Result := Value;
906   end;
907  
908 < function ExtractIdentifier(Dialect: Integer; Value: String): String;
908 > {$ELSE}
909 > {$IF declared(TRegex)}
910 > function ExtractConnectString(const CreateSQL: AnsiString;
911 >  var ConnectString: AnsiString): boolean;
912 > var Regex: TRegEx;
913 >    Match: TMatch;
914   begin
915 <  Value := Trim(Value);
916 <  if Dialect = 1 then
917 <    Value := AnsiUpperCase(Value)
915 >  Regex := TRegEx.Create('^ *CREATE +(DATABASE|SCHEMA) +''(.*)''',[roIgnoreCase]);
916 >  {extact database file spec}
917 >  Match := Regex.Match(CreateSQL);
918 >  Result := Match.Success and (Match.Groups.Count = 3);
919 >  if Result then
920 >    ConnectString := Match.Groups[2].Value;
921 > end;
922 >
923 > function ParseConnectString(ConnectString: AnsiString; var ServerName,
924 >  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
925 >  ): boolean;
926 >
927 > var Regex: TRegEx;
928 >    Match: TMatch;
929 > begin
930 >  ServerName := '';
931 >  DatabaseName := ConnectString;
932 >  PortNo := '';
933 >  Protocol := unknownProtocol;
934 >  {extact database file spec}
935 >  Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$',[roIgnoreCase]);
936 >  Result := Match.Success and (Match.Groups.Count = 5);
937 >  if Result then
938 >  begin
939 >    {URL type connect string}
940 >    Protocol := SchemeToProtocol(Match.Groups[1].Value);
941 >    ServerName := Match.Groups[2].Value;
942 >    PortNo := Match.Groups[3].Value;
943 >    DatabaseName := Match.Groups[4].Value;
944 >    if ServerName = '' then
945 >      DatabaseName := '/' + DatabaseName;
946 >  end
947    else
948    begin
949 <    if (Value <> '') and (Value[1] = '"') then
949 >    {URL type connect string - local loop}
950 >    Match := Regex.Match(ConnectString,'^([a-zA-Z46]+)://(.*)$',[roIgnoreCase]);
951 >    Result := Match.Success and (Match.Groups.Count = 3);
952 >    if Result then
953      begin
954 <      Delete(Value, 1, 1);
955 <      Delete(Value, Length(Value), 1);
193 <      Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
954 >      Protocol := SchemeToProtocol(Match.Groups[1].Value);
955 >      DatabaseName := Match.Groups[2].Value;
956      end
957      else
958 <      Value := AnsiUpperCase(Value);
958 >    begin
959 >      Match := Regex.Match(ConnectString,'^([a-zA-Z]:\\.*)',[roIgnoreCase]);
960 >      Result := Match.Success;
961 >      if Result then
962 >        Protocol := Local {Windows with leading drive ID}
963 >      else
964 >      begin
965 >        Match := Regex.Match(ConnectString,'^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$',[roIgnoreCase]);
966 >        Result := Match.Success and (Match.Groups.Count = 4);
967 >        if Result then
968 >        begin
969 >          {Legacy TCP Format}
970 >          ServerName := Match.Groups[1].Value;
971 >          PortNo := Match.Groups[2].Value;
972 >          DatabaseName := Match.Groups[3].Value;
973 >          Protocol := TCP;
974 >        end
975 >        else
976 >        begin
977 >          Match := Regex.Match(ConnectString,'^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$',[roIgnoreCase]);
978 >          Result := Match.Success and (Match.Groups.Count = 4);
979 >          if Result then
980 >          begin
981 >            {Netbui}
982 >            ServerName := Match.Groups[1].Value;
983 >            PortNo := Match.Groups[2].Value;
984 >            DatabaseName := Match.Groups[3].Value;
985 >            Protocol := NamedPipe
986 >          end
987 >          else
988 >          begin
989 >            Result := true;
990 >            Protocol := Local; {Assume local}
991 >          end;
992 >        end;
993 >      end;
994 >    end;
995    end;
198 –  Result := Value;
996   end;
997 <
998 < function IsReservedWord(w: string): boolean;
997 > {$ELSE}
998 > {cruder version of above for Delphi < XE. Older versions lack regular expression
999 > handling.}
1000 > function ExtractConnectString(const CreateSQL: AnsiString;
1001 >  var ConnectString: AnsiString): boolean;
1002   var i: integer;
1003   begin
1004 <     Result := true;
1005 <     for i := 0 to Length(sqlReservedWords) - 1 do
1006 <         if w = sqlReservedWords[i] then
1007 <            Exit;
1008 <     Result := false;
1004 >  Result := false;
1005 >  i := Pos('''',CreateSQL);
1006 >  if i > 0 then
1007 >  begin
1008 >    ConnectString := CreateSQL;
1009 >    delete(ConnectString,1,i);
1010 >    i := Pos('''',ConnectString);
1011 >    if i > 0 then
1012 >    begin
1013 >      delete(ConnectString,i,Length(ConnectString)-i+1);
1014 >      Result := true;
1015 >    end;
1016 >  end;
1017   end;
1018  
1019 < function QuoteIdentifier(Dialect: Integer; Value: String): String;
1019 > function ParseConnectString(ConnectString: AnsiString;
1020 >              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1021 >              var PortNo: AnsiString): boolean;
1022   begin
1023 <  if Dialect = 1 then
1024 <    Value := AnsiUpperCase(Trim(Value))
1025 <  else
1026 <    Value := '"' + Value + '"';
1027 <  Result := Value;
1023 >  Result := false;
1024 > end;
1025 >
1026 > {$IFEND}
1027 > {$IFEND}
1028 >
1029 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
1030 > var ServerName,
1031 >    DatabaseName: AnsiString;
1032 >    PortNo: AnsiString;
1033 > begin
1034 >  if not ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo) then
1035 >    Result := unknownProtocol;
1036   end;
1037  
1038 < function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
1038 > {Make a connect string in format appropriate protocol}
1039 >
1040 > function MakeConnectString(ServerName, DatabaseName: AnsiString;
1041 >  Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1042 >
1043 >  function FormatURL: AnsiString;
1044 >  begin
1045 >    if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
1046 >      Result := DatabaseName
1047 >    else
1048 >      Result := ServerName + '/' + DatabaseName;
1049 >  end;
1050 >
1051   begin
1052 +  if ServerName = '' then ServerName := 'localhost';
1053 +  if PortNo <> '' then
1054 +    case Protocol of
1055 +    NamedPipe:
1056 +      ServerName := ServerName + '@' + PortNo;
1057 +    Local,
1058 +    SPX,
1059 +    xnet: {do nothing};
1060 +    TCP:
1061 +      ServerName := ServerName + '/' + PortNo;
1062 +    else
1063 +      ServerName := ServerName + ':' + PortNo;
1064 +    end;
1065 +
1066 +  case Protocol of
1067 +    TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
1068 +    SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
1069 +    NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
1070 +    Local:      Result := DatabaseName; {do not localize}
1071 +    inet:       Result := 'inet://' + FormatURL; {do not localize}
1072 +    inet4:       Result := 'inet4://' + FormatURL; {do not localize}
1073 +    inet6:       Result := 'inet6://' + FormatURL; {do not localize}
1074 +    wnet:       Result := 'wnet://' + FormatURL; {do not localize}
1075 +    xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
1076 +  end;
1077 + end;
1078 +
1079 + {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1080 +
1081 + function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1082 + begin
1083 +  Value := TrimRight(Value);
1084    if (Dialect = 3) and
1085 <    ((AnsiUpperCase(Value) <> Value) or IsReservedWord(Value)) then
1086 <     Result := '"' + Value + '"'
1085 >    (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1086 >     Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
1087    else
1088      Result := Value
1089   end;
1090  
1091 < function Space2Underscore(s: string): string;
1091 > {Replaces unknown characters in a string with underscores}
1092 >
1093 > function Space2Underscore(s: AnsiString): AnsiString;
1094   var
1095     k: integer;
1096   begin
1097       Result := s;
1098       for k := 1 to Length(s) do
1099 <         if not (Result[k] in ['0'..'9','A'..'Z','_','$'])  then
1099 >         if not (Result[k] in ValidSQLIdentifierChars)  then
1100              Result[k] := '_';
1101   end;
1102  
1103 + {Reformats an SQL string with single quotes duplicated.}
1104 +
1105 + function SQLSafeString(const s: AnsiString): AnsiString;
1106 + begin
1107 +  Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1108 + end;
1109 +
1110 + { TSQLParamProcessor }
1111 +
1112 + function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1113 +  var slNames: TStrings): AnsiString;
1114 + var token: TSQLTokens;
1115 +    iParamSuffix: Integer;
1116 + begin
1117 +  Result := '';
1118 +  iParamSuffix := 0;
1119 +
1120 +  while not EOF do
1121 +  begin
1122 +    token := GetNextToken;
1123 +    case token of
1124 +    sqltParam,
1125 +    sqltQuotedParam:
1126 +      begin
1127 +        Result := Result + '?';
1128 +        slNames.Add(TokenText);
1129 +      end;
1130 +
1131 +    sqltPlaceHolder:
1132 +      if GenerateParamNames then
1133 +      begin
1134 +        Inc(iParamSuffix);
1135 +        slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1136 +                                            //add pointer to self to mark entry
1137 +        Result := Result + '?';
1138 +      end
1139 +      else
1140 +        IBError(ibxeSQLParseError, [SParamNameExpected]);
1141 +
1142 +    sqltQuotedString:
1143 +      Result := Result + '''' + SQLSafeString(TokenText) + '''';
1144 +
1145 +    sqltIdentifierInDoubleQuotes:
1146 +      Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1147 +
1148 +    sqltComment:
1149 +      Result := Result + '/*' + TokenText + '*/';
1150 +
1151 +    sqltCommentLine:
1152 +      Result := Result + '--' + TokenText + LineEnding;
1153 +
1154 +    sqltEOL:
1155 +      Result := Result + LineEnding;
1156 +
1157 +    else
1158 +      Result := Result + TokenText;
1159 +    end;
1160 +  end;
1161 + end;
1162 +
1163 + function TSQLParamProcessor.GetChar: AnsiChar;
1164 + begin
1165 +  if FIndex <= Length(FInString) then
1166 +  begin
1167 +    Result := FInString[FIndex];
1168 +    Inc(FIndex);
1169 +  end
1170 +  else
1171 +    Result := #0;
1172 + end;
1173 +
1174 + class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1175 +  GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1176 + begin
1177 +  with self.Create do
1178 +  try
1179 +    FInString := sSQL;
1180 +    FIndex := 1;
1181 +    Result := DoExecute(GenerateParamNames,slNames);
1182 +  finally
1183 +    Free;
1184 +  end;
1185 + end;
1186 +
1187 + { TSQLwithNamedParamsTokeniser }
1188 +
1189 + procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1190 + begin
1191 +  inherited Assign(source);
1192 +  if source is TSQLwithNamedParamsTokeniser then
1193 +  begin
1194 +    FState := TSQLwithNamedParamsTokeniser(source).FState;
1195 +    FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1196 +  end;
1197 + end;
1198 +
1199 + procedure TSQLwithNamedParamsTokeniser.Reset;
1200 + begin
1201 +  inherited Reset;
1202 +  FState := stInit;
1203 +  FNested := 0;
1204 + end;
1205 +
1206 + function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1207 +  ): boolean;
1208 + begin
1209 +  Result := inherited TokenFound(token);
1210 +  if not Result then Exit;
1211 +
1212 +  case FState of
1213 +  stInit:
1214 +    begin
1215 +      case token of
1216 +      sqltColon:
1217 +        begin
1218 +          FState := stInParam;
1219 +          ResetQueue(token);
1220 +        end;
1221 +
1222 +      sqltBegin:
1223 +        begin
1224 +          FState := stInBlock;
1225 +          FNested := 1;
1226 +        end;
1227 +
1228 +      sqltOpenSquareBracket:
1229 +          FState := stInArrayDim;
1230 +
1231 +      end;
1232 +    end;
1233 +
1234 +  stInParam:
1235 +    begin
1236 +      case token of
1237 +      sqltIdentifier:
1238 +        token := sqltParam;
1239 +
1240 +      sqltIdentifierInDoubleQuotes:
1241 +        token := sqltQuotedParam;
1242 +
1243 +      else
1244 +        begin
1245 +          QueueToken(token);
1246 +          ReleaseQueue(token);
1247 +        end;
1248 +      end;
1249 +      FState := stInit;
1250 +    end;
1251 +
1252 +  stInBlock:
1253 +    begin
1254 +      case token of
1255 +      sqltBegin,
1256 +      sqltCase:
1257 +          Inc(FNested);
1258 +
1259 +      sqltEnd:
1260 +        begin
1261 +          Dec(FNested);
1262 +          if FNested = 0 then
1263 +            FState := stInit;
1264 +        end;
1265 +      end;
1266 +    end;
1267 +
1268 +    stInArrayDim:
1269 +      begin
1270 +        if token = sqltCloseSquareBracket then
1271 +            FState := stInit;
1272 +      end;
1273 +    end;
1274 +
1275 +  Result := (FState <> stInParam);
1276 + end;
1277 +
1278 + { TSQLTokeniser }
1279 +
1280 + function TSQLTokeniser.GetNext: TSQLTokens;
1281 + var C: AnsiChar;
1282 + begin
1283 +  if EOF then
1284 +    Result := sqltEOF
1285 +  else
1286 +  begin
1287 +    C := GetChar;
1288 +    case C of
1289 +    #0:
1290 +      Result := sqltEOF;
1291 +    ' ',TAB:
1292 +      Result := sqltSpace;
1293 +    '0'..'9':
1294 +      Result := sqltNumberString;
1295 +    ';':
1296 +      Result := sqltSemiColon;
1297 +    '?':
1298 +      Result := sqltPlaceholder;
1299 +    '|':
1300 +      Result := sqltPipe;
1301 +    '"':
1302 +      Result := sqltDoubleQuotes;
1303 +    '''':
1304 +      Result := sqltSingleQuotes;
1305 +    '/':
1306 +      Result := sqltForwardSlash;
1307 +    '\':
1308 +      Result := sqltBackslash;
1309 +    '*':
1310 +      Result := sqltAsterisk;
1311 +    '(':
1312 +      Result := sqltOpenBracket;
1313 +    ')':
1314 +      Result := sqltCloseBracket;
1315 +    ':':
1316 +      Result := sqltColon;
1317 +    ',':
1318 +      Result := sqltComma;
1319 +    '.':
1320 +      Result := sqltPeriod;
1321 +    '=':
1322 +      Result := sqltEquals;
1323 +    '[':
1324 +      Result := sqltOpenSquareBracket;
1325 +    ']':
1326 +      Result := sqltCloseSquareBracket;
1327 +    '-':
1328 +      Result := sqltMinus;
1329 +    '<':
1330 +      Result := sqltLT;
1331 +    '>':
1332 +      Result := sqltGT;
1333 +    CR:
1334 +      Result := sqltCR;
1335 +    LF:
1336 +      Result := sqltEOL;
1337 +    else
1338 +      if C in ValidSQLIdentifierChars then
1339 +        Result := sqltIdentifier
1340 +      else
1341 +        Result := sqltOtherCharacter;
1342 +    end;
1343 +    FLastChar := C
1344 +  end;
1345 +  FNextToken := Result;
1346 + end;
1347 +
1348 + procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1349 + begin
1350 +  if FQFirst = FQLast then
1351 +    IBError(ibxeTokenQueueUnderflow,[]);
1352 +  token := FTokenQueue[FQFirst].token;
1353 +  FString := FTokenQueue[FQFirst].text;
1354 +  Inc(FQFirst);
1355 +  if FQFirst = FQLast then
1356 +    FQueueState := tsHold;
1357 + end;
1358 +
1359 + procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1360 + begin
1361 +  FString := source.FString;
1362 +  FNextToken := source.FNextToken;
1363 +  FTokenQueue := source.FTokenQueue;
1364 +  FQueueState := source.FQueueState;
1365 +  FQFirst := source.FQFirst;
1366 +  FQLast := source.FQLast;
1367 + end;
1368 +
1369 + function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1370 + begin
1371 +  Result := (FState = stDefault);
1372 +  if Result and (token = sqltIdentifier)  then
1373 +    FindReservedWord(FString,token);
1374 + end;
1375 +
1376 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1377 + begin
1378 +  if FQLast > TokenQueueMaxSize then
1379 +    IBError(ibxeTokenQueueOverflow,[]);
1380 +  FTokenQueue[FQLast].token := token;
1381 +  FTokenQueue[FQLast].text := text;
1382 +  Inc(FQLast);
1383 + end;
1384 +
1385 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1386 + begin
1387 +  QueueToken(token,TokenText);
1388 + end;
1389 +
1390 + procedure TSQLTokeniser.ResetQueue;
1391 + begin
1392 +  FQFirst := 0;
1393 +  FQLast := 0;
1394 +  FQueueState := tsHold;
1395 + end;
1396 +
1397 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1398 + begin
1399 +  ResetQueue;
1400 +  QueueToken(token,text);
1401 + end;
1402 +
1403 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1404 + begin
1405 +  ResetQueue;
1406 +  QueueToken(token);
1407 + end;
1408 +
1409 + procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1410 + begin
1411 +  FQueueState := tsRelease;
1412 +  PopQueue(token);
1413 + end;
1414 +
1415 + procedure TSQLTokeniser.ReleaseQueue;
1416 + begin
1417 +  FQueueState := tsRelease;
1418 + end;
1419 +
1420 + function TSQLTokeniser.GetQueuedText: AnsiString;
1421 + var i: integer;
1422 + begin
1423 +  Result := '';
1424 +  for i := FQFirst to FQLast do
1425 +    Result := Result + FTokenQueue[i].text;
1426 + end;
1427 +
1428 + procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1429 + begin
1430 +  FString := text;
1431 + end;
1432 +
1433 + constructor TSQLTokeniser.Create;
1434 + begin
1435 +  inherited Create;
1436 +  Reset;
1437 + end;
1438 +
1439 + destructor TSQLTokeniser.Destroy;
1440 + begin
1441 +  Reset;
1442 +  inherited Destroy;
1443 + end;
1444 +
1445 + procedure TSQLTokeniser.Reset;
1446 + begin
1447 +  FNextToken := sqltInit;
1448 +  FState := stDefault;
1449 +  FString := '';
1450 +  FEOF := false;
1451 +  ResetQueue;
1452 + end;
1453 +
1454 + function TSQLTokeniser.GetNextToken: TSQLTokens;
1455 + begin
1456 +  if FQueueState = tsRelease then
1457 +  repeat
1458 +    PopQueue(Result);
1459 +    FEOF := Result = sqltEOF;
1460 +    if TokenFound(Result) then
1461 +      Exit;
1462 +  until FQueueState <> tsRelease;
1463 +
1464 +  Result := InternalGetNextToken;
1465 + end;
1466 +
1467 + {a simple lookahead one algorithm to extra the next symbol}
1468 +
1469 + function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1470 + var C: AnsiChar;
1471 + begin
1472 +  Result := sqltEOF;
1473 +
1474 +  if FNextToken = sqltInit then
1475 +    GetNext;
1476 +
1477 +  repeat
1478 +    if FSkipNext then
1479 +    begin
1480 +      FSkipNext := false;
1481 +      GetNext;
1482 +    end;
1483 +
1484 +    Result := FNextToken;
1485 +    C := FLastChar;
1486 +    GetNext;
1487 +
1488 +    if (Result = sqltCR) and (FNextToken = sqltEOL) then
1489 +    begin
1490 +      FSkipNext := true;
1491 +      Result := sqltEOL;
1492 +      C := LF;
1493 +    end;
1494 +
1495 +    case FState of
1496 +    stInComment:
1497 +      begin
1498 +        if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1499 +        begin
1500 +          FState := stDefault;
1501 +          Result := sqltComment;
1502 +          GetNext;
1503 +        end
1504 +        else
1505 +        if Result = sqltEOL then
1506 +          FString := FString + LineEnding
1507 +        else
1508 +          FString := FString + C;
1509 +      end;
1510 +
1511 +    stInCommentLine:
1512 +      begin
1513 +        case Result of
1514 +        sqltEOL:
1515 +          begin
1516 +            FState := stDefault;
1517 +            Result := sqltCommentLine;
1518 +          end;
1519 +
1520 +        else
1521 +          FString := FString + C;
1522 +        end;
1523 +      end;
1524 +
1525 +    stSingleQuoted:
1526 +      begin
1527 +        if (Result = sqltSingleQuotes) then
1528 +        begin
1529 +          if (FNextToken = sqltSingleQuotes) then
1530 +          begin
1531 +            FSkipNext := true;
1532 +            FString := FString + C;
1533 +          end
1534 +          else
1535 +          begin
1536 +            Result := sqltQuotedString;
1537 +            FState := stDefault;
1538 +          end;
1539 +        end
1540 +        else
1541 +        if Result = sqltEOL then
1542 +          FString := FString + LineEnding
1543 +        else
1544 +          FString := FString + C;
1545 +      end;
1546 +
1547 +    stDoubleQuoted:
1548 +      begin
1549 +        if (Result = sqltDoubleQuotes) then
1550 +        begin
1551 +          if (FNextToken = sqltDoubleQuotes) then
1552 +          begin
1553 +            FSkipNext := true;
1554 +            FString := FString + C;
1555 +          end
1556 +          else
1557 +          begin
1558 +            Result := sqltIdentifierInDoubleQuotes;
1559 +            FState := stDefault;
1560 +          end;
1561 +        end
1562 +        else
1563 +        if Result = sqltEOL then
1564 +          FString := FString + LineEnding
1565 +        else
1566 +          FString := FString + C;
1567 +      end;
1568 +
1569 +    stInIdentifier:
1570 +      begin
1571 +        FString := FString + C;
1572 +        Result := sqltIdentifier;
1573 +        if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1574 +          FState := stDefault
1575 +      end;
1576 +
1577 +    stInNumeric:
1578 +      begin
1579 +        FString := FString + C;
1580 +        if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1581 +        begin
1582 +          {malformed decimal}
1583 +          FState := stInIdentifier;
1584 +          Result := sqltIdentifier
1585 +        end
1586 +        else
1587 +        begin
1588 +          if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1589 +            FState := stDefault;
1590 +          Result := sqltNumberString;
1591 +        end;
1592 +      end;
1593 +
1594 +    else {stDefault}
1595 +      begin
1596 +        FString := C;
1597 +        case Result of
1598 +
1599 +        sqltPipe:
1600 +          if FNextToken = sqltPipe then
1601 +          begin
1602 +            Result := sqltConcatSymbol;
1603 +            FString := C + FLastChar;
1604 +            GetNext;
1605 +          end;
1606 +
1607 +        sqltForwardSlash:
1608 +          begin
1609 +            if FNextToken = sqltAsterisk then
1610 +            begin
1611 +              FString := '';
1612 +              GetNext;
1613 +              FState := stInComment;
1614 +            end
1615 +          end;
1616 +
1617 +        sqltMinus:
1618 +          begin
1619 +            if FNextToken = sqltMinus then
1620 +            begin
1621 +              FString := '';
1622 +              GetNext;
1623 +              FState := stInCommentLine;
1624 +            end;
1625 +          end;
1626 +
1627 +        sqltSingleQuotes:
1628 +          begin
1629 +            FString := '';
1630 +            FState := stSingleQuoted;
1631 +          end;
1632 +
1633 +        sqltDoubleQuotes:
1634 +          begin
1635 +            FString := '';
1636 +            FState := stDoubleQuoted;
1637 +          end;
1638 +
1639 +        sqltIdentifier:
1640 +          if FNextToken in [sqltIdentifier,sqltNumberString] then
1641 +            FState := stInIdentifier;
1642 +
1643 +        sqltNumberString:
1644 +          if FNextToken in [sqltNumberString,sqltPeriod] then
1645 +            FState := stInNumeric;
1646 +
1647 +        sqltEOL:
1648 +          FString := LineEnding;
1649 +        end;
1650 +      end;
1651 +    end;
1652 +
1653 + //    writeln(FString);
1654 +    FEOF := Result = sqltEOF;
1655 +  until TokenFound(Result) or EOF;
1656 + end;
1657 +
1658 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1659 +  var aTimezone: AnsiString; TimeOnly: boolean): boolean;
1660 + {$IF declared(TFormatSettings)}
1661 + begin
1662 +    {$IF declared(DefaultFormatSettings)}
1663 +    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,DefaultFormatSettings,TimeOnly);
1664 +    {$ELSE}
1665 +    {$IF declared(FormatSettings)}
1666 +    Result := ParseDateTimeTZString(aDateTimeStr,aDateTime,aTimeZone,FormatSettings,TimeOnly);
1667 +    {$IFEND} {$IFEND}
1668 + end;
1669 +
1670 + function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
1671 +              var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean;
1672 + {$IFEND}
1673 + const
1674 +  whitespacechars = [' ',#$09,#$0A,#$0D];
1675 + var i,j,l: integer;
1676 +    aTime: TDateTime;
1677 +    DMs: longint;
1678 + begin
1679 +  Result := false;
1680 +  aTimezone := '';
1681 +  if aDateTimeStr <> '' then
1682 +  {$if declared(TFormatSettings)}
1683 +  with aFormatSettings do
1684 +  {$IFEND}
1685 +  begin
1686 +    aDateTime := 0;
1687 +    {Parse to get time zone info}
1688 +    i := 1;
1689 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1690 +    if not TimeOnly then
1691 +    begin
1692 +      {decode date}
1693 +      j := i;
1694 +      while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',DateSeparator]) do inc(j);
1695 +      if TryStrToDate(system.copy(aDateTimeStr,i,j-i),aDateTime) then
1696 +        i := j; {otherwise start again i.e. assume time only}
1697 +    end;
1698 +
1699 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1700 +    {decode time}
1701 +    j := i;
1702 +    while (j <= length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9',TimeSeparator]) do inc(j);
1703 +    Result := TryStrToTime(system.copy(aDateTimeStr,i,j-i),aTime);
1704 +    if not Result then Exit;
1705 +    aDateTime := aDateTime + aTime;
1706 +    i := j;
1707 +
1708 +    {is there a factional second part}
1709 +    if (i <= length(aDateTimeStr)) and (aDateTimeStr[i] = '.') then
1710 +    begin
1711 +      inc(i);
1712 +      inc(j);
1713 +      while (j <= Length(aDateTimeStr)) and (aDateTimeStr[j] in ['0'..'9']) do inc(j);
1714 +      if j > i then
1715 +      begin
1716 +        l := j-i;
1717 +        if l > 4 then l := 4;
1718 +        Result := TryStrToInt(system.copy(aDateTimeStr,i,l),DMs);
1719 +        if not Result then Exit;
1720 +
1721 +        {adjust for number of significant digits}
1722 +        case l of
1723 +        3:   DMs := DMs * 10;
1724 +        2:   DMs := DMs * 100;
1725 +        1:   DMs := DMs * 1000;
1726 +        end;
1727 +       aDateTime := aDateTime + (DMs / (MsecsPerDay*10));
1728 +      end;
1729 +    end;
1730 +    i := j;
1731 +
1732 +    while (i <= length(aDateTimeStr)) and (aDateTimeStr[i] in whitespacechars) do inc(i); {skip white space}
1733 +    {decode time zone}
1734 +    if i < length(aDateTimeStr) then
1735 +    begin
1736 +      j := i;
1737 +      while (j <= length(aDateTimeStr)) and not (aDateTimeStr[j] in whitespacechars) do inc(j);
1738 +      aTimezone := system.copy(aDateTimeStr,i,j-i);
1739 +    end;
1740 +    Result := true;
1741 +  end
1742 + end;
1743 +
1744 + {The following is similar to FPC DecodeTime except that the Firebird standard
1745 + decimilliseconds is used instead of milliseconds for fractional seconds}
1746 +
1747 + procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word;
1748 +  var DeciMillisecond: cardinal);
1749 + var D : Double;
1750 +    l : cardinal;
1751 + begin
1752 +  {conversion to decimilliseconds hacked from FPC DateTimeToTimeStamp}
1753 +  D := aTime * MSecsPerDay *10;
1754 +  if D < 0 then
1755 +    D := D - 0.5
1756 +  else
1757 +    D := D + 0.5;
1758 +  {rest hacked from FPC DecodeTIme}
1759 +  l := Abs(Trunc(D)) Mod (MSecsPerDay*10);
1760 +  Hour   := l div 36000000;
1761 +  l := l mod 36000000;
1762 +  Minute := l div 600000;
1763 +  l := l mod 600000;
1764 +  Second := l div 10000;
1765 +  DeciMillisecond := l mod 10000;
1766 + end;
1767 +
1768 + {The following is similar to FPC EncodeTime except that the Firebird standard
1769 + decimilliseconds is used instead of milliseconds for fractional seconds}
1770 +
1771 + function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
1772 + const DMSecsPerDay = MSecsPerDay*10;
1773 + var DMs: cardinal;
1774 +    D: Double;
1775 + begin
1776 +  if (Hour<24) and (Minute<60) and (Second<60) and (DeciMillisecond<10000) then
1777 +  begin
1778 +    DMs := Hour*36000000+Minute*600000+Second*10000+DeciMillisecond;
1779 +    D := DMs/DMSecsPerDay;
1780 +    Result:=TDateTime(d)
1781 +  end
1782 +  else
1783 +    IBError(ibxeBadTimeSpecification,[Hour, Minute, Second, DeciMillisecond]);
1784 + end;
1785 +
1786 + {The following is similar to FPC FormatDateTime except that it additionally
1787 + allows the timstamp to have a fractional seconds component with a resolution
1788 + of four decimal places. This is appended to the result for FormatDateTime
1789 + if the format string contains a "zzzz' string.}
1790 +
1791 + function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
1792 + var Hour, Minute, Second: word;
1793 +    DeciMillisecond: cardinal;
1794 + begin
1795 +  if Pos('zzzz',fmt) > 0 then
1796 +  begin
1797 +    FBDecodeTime(aDateTime, Hour, Minute, Second, DeciMillisecond);
1798 +    fmt := StringReplace(fmt, 'zzzz', Format('%.4d',[DeciMillisecond]), [rfReplaceAll]);
1799 +  end;
1800 +  Result := FormatDateTime(fmt,aDateTime);
1801 + end;
1802 +
1803 + function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
1804 + begin
1805 +  if EffectiveTimeOffsetMins > 0 then
1806 +    Result := Format('+%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)])
1807 +  else
1808 +    Result := Format('%.2d:%.2d',[EffectiveTimeOffsetMins div 60,abs(EffectiveTimeOffsetMins mod 60)]);
1809 + end;
1810 +
1811 + function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
1812 + var i: integer;
1813 + begin
1814 +  Result := false;
1815 +  TZOffset := Trim(TZOffset);
1816 +  for i := 1 to Length(TZOffset) do
1817 +    if not (TZOffset[i] in ['0'..'9','-','+',':']) then Exit;
1818 +
1819 +  Result := true;
1820 +  i := Pos(':',TZOffset);
1821 +  if i > 0 then
1822 +    dstOffset := StrToInt(copy(TZOffset,1,i-1)) * 60 + StrToInt(copy(TZOffset,i + 1))
1823 +  else
1824 +    dstOffset := StrToInt(TZOffset) * 60;
1825 + end;
1826 +
1827 + function StripLeadingZeros(Value: AnsiString): AnsiString;
1828 + var i: Integer;
1829 +    start: integer;
1830 + begin
1831 +  Result := '';
1832 +  start := 1;
1833 +  if (Length(Value) > 0) and (Value[1] = '-') then
1834 +  begin
1835 +    Result := '-';
1836 +    start := 2;
1837 +  end;
1838 +  for i := start to Length(Value) do
1839 +    if Value[i] <> '0' then
1840 +    begin
1841 +      Result := Result + system.copy(Value, i, MaxInt);
1842 +      Exit;
1843 +    end;
1844 + end;
1845 +
1846 + function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
1847 + var i: integer;
1848 +    ds: integer;
1849 +    exponent: integer;
1850 + begin
1851 +  Result := false;
1852 +  ds := 0;
1853 +  exponent := 0;
1854 +  S := Trim(S);
1855 +  Value := 0;
1856 +  scale := 0;
1857 +  if Length(S) = 0 then
1858 +    Exit;
1859 +  {$IF declared(DefaultFormatSettings)}
1860 +  with DefaultFormatSettings do
1861 +  {$ELSE}
1862 +  {$IF declared(FormatSettings)}
1863 +  with FormatSettings do
1864 +  {$IFEND}
1865 +  {$IFEND}
1866 +  begin
1867 +    {ThousandSeparator not allowed as by Delphi specs}
1868 +    if (ThousandSeparator <> DecimalSeparator) and
1869 +       (Pos(ThousandSeparator, S) <> 0) then
1870 +        Exit;
1871 +
1872 +    for i := length(S) downto 1 do
1873 +    begin
1874 +      if S[i] = AnsiChar(DecimalSeparator) then
1875 +      begin
1876 +          if ds <> 0 then Exit; {only one allowed}
1877 +          ds := i-1;
1878 +          dec(exponent);
1879 +          system.Delete(S,i,1);
1880 +      end
1881 +      else
1882 +      if S[i] in ['+','-'] then
1883 +      begin
1884 +       if (i > 1) and not (S[i-1] in ['e','E']) then
1885 +          Exit; {malformed}
1886 +      end
1887 +      else
1888 +      if S[i] in ['e','E'] then {scientific notation}
1889 +      begin
1890 +        if ds <> 0 then Exit; {not permitted in exponent}
1891 +        if exponent <> 0 then Exit; {only one allowed}
1892 +        exponent := i;
1893 +      end
1894 +      else
1895 +      if not (S[i] in ['0'..'9']) then
1896 +          Exit; {bad character}
1897 +    end;
1898 +
1899 +    if exponent > 0 then
1900 +    begin
1901 +      Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1902 +      if Result then
1903 +      begin
1904 +        {adjust scale for decimal point}
1905 +        if ds > 0 then
1906 +          Scale := Scale - (exponent - ds - 1);
1907 +        Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1908 +      end;
1909 +    end
1910 +    else
1911 +    begin
1912 +      if ds <> 0 then
1913 +        scale := ds - Length(S);
1914 +      Result := TryStrToInt64(S,Value);
1915 +    end;
1916 +  end;
1917 + end;
1918 +
1919 + function NumericToDouble(aValue: Int64; aScale: integer): double;
1920 + begin
1921 +  Result := aValue * IntPower(10,aScale)
1922 + end;
1923  
1924   end.

Diff Legend

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