ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
Revision: 353
Committed: Sat Oct 23 14:11:37 2021 UTC (2 years, 5 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/IBUtils.pas
File size: 46897 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
1 {************************************************************************}
2 { }
3 { Borland Delphi Visual Component Library }
4 { InterBase Express core components }
5 { }
6 { Copyright (c) 1998-2000 Inprise Corporation }
7 { }
8 { InterBase Express is based in part on the product }
9 { Free IB Components, written by Gregory H. Deatz for }
10 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11 { Free IB Components is used under license. }
12 { }
13 { The contents of this file are subject to the InterBase }
14 { Public License Version 1.0 (the "License"); you may not }
15 { use this file except in compliance with the License. You }
16 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 { Software distributed under the License is distributed on }
18 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19 { express or implied. See the License for the specific language }
20 { governing rights and limitations under the License. }
21 { The Original Code was created by InterBase Software Corporation }
22 { and its successors. }
23 { Portions created by Inprise Corporation are Copyright (C) Inprise }
24 { Corporation. All Rights Reserved. }
25 { Contributor(s): Jeff Overcash }
26 { }
27 { IBX For Lazarus (Firebird Express) }
28 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 { Portions created by MWA Software are copyright McCallum Whyman }
30 { Associates Ltd 2011 }
31 { }
32 {************************************************************************}
33
34 unit IBUtils;
35 {$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 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;
299 CR = #13;
300 LF = #10;
301 TAB = #9;
302 NULL_TERMINATOR = #0;
303
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): AnsiString;
621 function RandomInteger(iLow, iHigh: Integer): Integer;
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
671 result := n1
672 else
673 result := n2;
674 end;
675
676 function Min(n1, n2: Integer): Integer;
677 begin
678 if (n1 < n2) then
679 result := n1
680 else
681 result := n2;
682 end;
683
684 function RandomString(iLength: Integer): AnsiString;
685 begin
686 result := '';
687 while Length(result) < iLength do
688 result := result + IntToStr(RandomInteger(0, High(Integer)));
689 if Length(result) > iLength then
690 result := Copy(result, 1, iLength);
691 end;
692
693 function RandomInteger(iLow, iHigh: Integer): Integer;
694 begin
695 result := Trunc(Random(iHigh - iLow)) + iLow;
696 end;
697
698 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
699 var
700 i: Integer;
701 begin
702 result := '';
703 for i := 1 to Length(st) do begin
704 if AnsiPos(st[i], CharsToStrip) = 0 then
705 result := result + st[i];
706 end;
707 end;
708
709 {Extracts SQL Identifier typically from a Dialect 3 encoding}
710
711 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
712 begin
713 Value := Trim(Value);
714 if Dialect = 1 then
715 Value := AnsiUpperCase(Value)
716 else
717 begin
718 if (Value <> '') and (Value[1] = '"') then
719 begin
720 Delete(Value, 1, 1);
721 Delete(Value, Length(Value), 1);
722 Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
723 end
724 else
725 Value := AnsiUpperCase(Value);
726 end;
727 Result := Value;
728 end;
729
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 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 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 {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 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;
906 end;
907
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 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 {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 Protocol := SchemeToProtocol(Match.Groups[1].Value);
955 DatabaseName := Match.Groups[2].Value;
956 end
957 else
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;
996 end;
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 := 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 ParseConnectString(ConnectString: AnsiString;
1020 var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
1021 var PortNo: AnsiString): boolean;
1022 begin
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 {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 (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 {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 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 (i > 1) and (S[i] in ['+','-']) and not (S[i-1] in ['e','E']) then
1883 Exit {malformed}
1884 else
1885 if S[i] in ['e','E'] then {scientific notation}
1886 begin
1887 if ds <> 0 then Exit; {not permitted in exponent}
1888 if exponent <> 0 then Exit; {only one allowed}
1889 exponent := i;
1890 end
1891 else
1892 if not (S[i] in ['0'..'9']) then
1893 Exit; {bad character}
1894 end;
1895
1896 if exponent > 0 then
1897 begin
1898 Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1899 if Result then
1900 begin
1901 {adjust scale for decimal point}
1902 Scale := Scale - (exponent - ds - 1);
1903 Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1904 end;
1905 end
1906 else
1907 begin
1908 if ds <> 0 then
1909 scale := ds - Length(S);
1910 Result := TryStrToInt64(S,Value);
1911 end;
1912 end;
1913 end;
1914
1915 function NumericToDouble(aValue: Int64; aScale: integer): double;
1916 begin
1917 Result := aValue * IntPower(10,aScale)
1918 end;
1919
1920 end.