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

File Contents

# User Rev Content
1 tony 45 {************************************************************************}
2     { }
3     { Borland Delphi Visual Component Library }
4     { InterBase Express core components }
5     { }
6     { Copyright (c) 1998-2000 Inprise Corporation }
7     { }
8     { InterBase Express is based in part on the product }
9     { Free IB Components, written by Gregory H. Deatz for }
10     { Hoagland, Longo, Moran, Dunst & Doukas Company. }
11     { Free IB Components is used under license. }
12     { }
13     { The contents of this file are subject to the InterBase }
14     { Public License Version 1.0 (the "License"); you may not }
15     { use this file except in compliance with the License. You }
16     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17     { Software distributed under the License is distributed on }
18     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19     { express or implied. See the License for the specific language }
20     { governing rights and limitations under the License. }
21     { The Original Code was created by InterBase Software Corporation }
22     { and its successors. }
23     { Portions created by Inprise Corporation are Copyright (C) Inprise }
24     { Corporation. All Rights Reserved. }
25     { Contributor(s): Jeff Overcash }
26     { }
27     { IBX For Lazarus (Firebird Express) }
28     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29     { Portions created by MWA Software are copyright McCallum Whyman }
30     { Associates Ltd 2011 }
31     { }
32     {************************************************************************}
33    
34     unit IBUtils;
35 tony 56 {$IFDEF MSWINDOWS}
36 tony 118 {$DEFINE WINDOWS}
37 tony 56 {$ENDIF}
38 tony 45
39     {$IFDEF FPC}
40     {$Mode Delphi}
41     {$codepage UTF8}
42     {$ENDIF}
43    
44 tony 315 { $IF declared(CompilerVersion) and (CompilerVersion >= 22)}
45     { $define HASDELPHIREQEX}
46     { $IFEND}
47 tony 118
48 tony 45 interface
49    
50 tony 143 uses Classes, SysUtils, IB;
51 tony 45
52 tony 263 type
53     TSQLTokens = (
54    
55     {Reserved Words}
56    
57     sqltAdd,
58     sqltAdmin,
59     sqltAll,
60     sqltAlter,
61     sqltAnd,
62     sqltAny,
63     sqltAs,
64     sqltAt,
65     sqltAvg,
66     sqltBegin,
67     sqltBetween,
68     sqltBigint,
69     sqltBit_Length,
70     sqltBlob,
71     sqltBoolean,
72     sqltBoth,
73     sqltBy,
74     sqltCase,
75     sqltCast,
76     sqltChar,
77     sqltChar_Length,
78     sqltCharacter,
79     sqltCharacter_Length,
80     sqltCheck,
81     sqltClose,
82     sqltCollate,
83     sqltColumn,
84     sqltCommit,
85     sqltConnect,
86     sqltConstraint,
87     sqltCorr,
88     sqltCount,
89     sqltCovar_Pop,
90     sqltCovar_Samp,
91     sqltCreate,
92     sqltCross,
93     sqltCurrent,
94     sqltCurrent_Connection,
95     sqltCurrent_Date,
96     sqltCurrent_Role,
97     sqltCurrent_Time,
98     sqltCurrent_Timestamp,
99     sqltCurrent_Transaction,
100     sqltCurrent_User,
101     sqltCursor,
102     sqltDate,
103     sqltDay,
104     sqltDec,
105     sqltDecimal,
106     sqltDeclare,
107     sqltDefault,
108     sqltDelete,
109     sqltDeleting,
110     sqltDeterministic,
111     sqltDisconnect,
112     sqltDistinct,
113     sqltDouble,
114     sqltDrop,
115     sqltElse,
116     sqltEnd,
117     sqltEscape,
118     sqltExecute,
119     sqltExists,
120     sqltExternal,
121     sqltExtract,
122     sqltFalse,
123     sqltFetch,
124     sqltFilter,
125     sqltFloat,
126     sqltFor,
127     sqltForeign,
128     sqltFrom,
129     sqltFull,
130     sqltFunction,
131     sqltGdscode,
132     sqltGlobal,
133     sqltGrant,
134     sqltGroup,
135     sqltHaving,
136     sqltHour,
137     sqltIn,
138     sqltIndex,
139     sqltInner,
140     sqltInsensitive,
141     sqltInsert,
142     sqltInserting,
143     sqltInt,
144     sqltInteger,
145     sqltInto,
146     sqltIs,
147     sqltJoin,
148     sqltKey,
149     sqltLeading,
150     sqltLeft,
151     sqltLike,
152     sqltLong,
153     sqltLower,
154     sqltMax,
155     sqltMaximum_Segment,
156     sqltMerge,
157     sqltMin,
158     sqltMinute,
159     sqltMonth,
160     sqltNational,
161     sqltNatural,
162     sqltNchar,
163     sqltNo,
164     sqltNot,
165     sqltNull,
166     sqltNumeric,
167     sqltOctet_Length,
168     sqltOf,
169     sqltOffset,
170     sqltOn,
171     sqltOnly,
172     sqltOpen,
173     sqltOr,
174     sqltOrder,
175     sqltOuter,
176     sqltOver,
177     sqltParameter,
178     sqltPlan,
179     sqltPosition,
180     sqltPost_Event,
181     sqltPrecision,
182     sqltPrimary,
183     sqltProcedure,
184     sqltRdbDb_Key,
185     sqltRdbRecord_Version,
186     sqltReal,
187     sqltRecord_Version,
188     sqltRecreate,
189     sqltRecursive,
190     sqltReferences,
191     sqltRegr_Avgx,
192     sqltRegr_Avgy,
193     sqltRegr_Count,
194     sqltRegr_Intercept,
195     sqltRegr_R2,
196     sqltRegr_Slope,
197     sqltRegr_Sxx,
198     sqltRegr_Sxy,
199     sqltRegr_Syy,
200     sqltRelease,
201     sqltReturn,
202     sqltReturning_Values,
203     sqltReturns,
204     sqltRevoke,
205     sqltRight,
206     sqltRollback,
207     sqltRow,
208     sqltRows,
209     sqltRow_Count,
210     sqltSavepoint,
211     sqltScroll,
212     sqltSecond,
213     sqltSelect,
214     sqltSensitive,
215     sqltSet,
216     sqltSimilar,
217     sqltSmallint,
218     sqltSome,
219     sqltSqlcode,
220     sqltSqlstate,
221     sqltStart,
222     sqltStddev_Pop,
223     sqltStddev_Samp,
224     sqltSum,
225     sqltTable,
226     sqltThen,
227     sqltTime,
228     sqltTimestamp,
229     sqltTo,
230     sqltTrailing,
231     sqltTrigger,
232     sqltTrim,
233     sqltTrue,
234     sqltUnion,
235     sqltUnique,
236     sqltUnknown,
237     sqltUpdate,
238     sqltUpdating,
239     sqltUpper,
240     sqltUser,
241     sqltUsing,
242     sqltValue,
243     sqltValues,
244     sqltVar_Pop,
245     sqltVar_Samp,
246     sqltVarchar,
247     sqltVariable,
248     sqltVarying,
249     sqltView,
250     sqltWhen,
251     sqltWhere,
252     sqltWhile,
253     sqltWith,
254     sqltYear,
255    
256     {symbols}
257    
258     sqltSpace,
259     sqltSemiColon,
260     sqltPlaceholder,
261     sqltSingleQuotes,
262     sqltDoubleQuotes,
263 tony 270 sqltBackslash,
264 tony 263 sqltComma,
265     sqltPeriod,
266     sqltEquals,
267     sqltOtherCharacter,
268     sqltIdentifier,
269     sqltIdentifierInDoubleQuotes,
270     sqltNumberString,
271     sqltString,
272     sqltParam,
273     sqltQuotedParam,
274     sqltColon,
275     sqltComment,
276     sqltCommentLine,
277     sqltQuotedString,
278     sqltAsterisk,
279     sqltForwardSlash,
280     sqltOpenSquareBracket,
281     sqltCloseSquareBracket,
282     sqltOpenBracket,
283     sqltCloseBracket,
284     sqltPipe,
285 tony 287 sqltMinus,
286 tony 263 sqltConcatSymbol,
287     sqltLT,
288     sqltGT,
289     sqltCR,
290     sqltEOL,
291     sqltEOF,
292     sqltInit
293     );
294    
295     TSQLReservedWords = sqltAdd..sqltYear;
296    
297 tony 45 const
298     CRLF = #13 + #10;
299     CR = #13;
300     LF = #10;
301     TAB = #9;
302     NULL_TERMINATOR = #0;
303    
304 tony 263 {$IFNDEF FPC}
305     LineEnding = CRLF;
306     {$ENDIF}
307    
308     {SQL Reserved words in alphabetical order}
309    
310     sqlReservedWords: array [TSQLReservedWords] of string = (
311 tony 47 'ADD',
312     'ADMIN',
313     'ALL',
314     'ALTER',
315     'AND',
316     'ANY',
317     'AS',
318     'AT',
319     'AVG',
320     'BEGIN',
321     'BETWEEN',
322     'BIGINT',
323     'BIT_LENGTH',
324     'BLOB',
325     'BOOLEAN',
326     'BOTH',
327     'BY',
328     'CASE',
329     'CAST',
330     'CHAR',
331     'CHAR_LENGTH',
332     'CHARACTER',
333     'CHARACTER_LENGTH',
334     'CHECK',
335     'CLOSE',
336     'COLLATE',
337     'COLUMN',
338     'COMMIT',
339     'CONNECT',
340     'CONSTRAINT',
341     'CORR',
342     'COUNT',
343     'COVAR_POP',
344     'COVAR_SAMP',
345     'CREATE',
346     'CROSS',
347     'CURRENT',
348     'CURRENT_CONNECTION',
349     'CURRENT_DATE',
350     'CURRENT_ROLE',
351     'CURRENT_TIME',
352     'CURRENT_TIMESTAMP',
353     'CURRENT_TRANSACTION',
354     'CURRENT_USER',
355     'CURSOR',
356     'DATE',
357     'DAY',
358     'DEC',
359     'DECIMAL',
360     'DECLARE',
361     'DEFAULT',
362     'DELETE',
363     'DELETING',
364     'DETERMINISTIC',
365     'DISCONNECT',
366     'DISTINCT',
367     'DOUBLE',
368     'DROP',
369     'ELSE',
370     'END',
371     'ESCAPE',
372     'EXECUTE',
373     'EXISTS',
374     'EXTERNAL',
375     'EXTRACT',
376     'FALSE',
377     'FETCH',
378     'FILTER',
379     'FLOAT',
380     'FOR',
381     'FOREIGN',
382     'FROM',
383     'FULL',
384     'FUNCTION',
385     'GDSCODE',
386     'GLOBAL',
387     'GRANT',
388     'GROUP',
389     'HAVING',
390     'HOUR',
391     'IN',
392     'INDEX',
393     'INNER',
394     'INSENSITIVE',
395     'INSERT',
396     'INSERTING',
397     'INT',
398     'INTEGER',
399     'INTO',
400     'IS',
401     'JOIN',
402 tony 209 'KEY',
403 tony 47 'LEADING',
404     'LEFT',
405     'LIKE',
406     'LONG',
407     'LOWER',
408     'MAX',
409     'MAXIMUM_SEGMENT',
410     'MERGE',
411     'MIN',
412     'MINUTE',
413     'MONTH',
414     'NATIONAL',
415     'NATURAL',
416     'NCHAR',
417     'NO',
418     'NOT',
419     'NULL',
420     'NUMERIC',
421     'OCTET_LENGTH',
422     'OF',
423     'OFFSET',
424     'ON',
425     'ONLY',
426     'OPEN',
427     'OR',
428     'ORDER',
429     'OUTER',
430     'OVER',
431     'PARAMETER',
432     'PLAN',
433     'POSITION',
434     'POST_EVENT',
435     'PRECISION',
436     'PRIMARY',
437     'PROCEDURE',
438     'RDB$DB_KEY',
439     'RDB$RECORD_VERSION',
440     'REAL',
441     'RECORD_VERSION',
442     'RECREATE',
443     'RECURSIVE',
444     'REFERENCES',
445     'REGR_AVGX',
446     'REGR_AVGY',
447     'REGR_COUNT',
448     'REGR_INTERCEPT',
449     'REGR_R2',
450     'REGR_SLOPE',
451     'REGR_SXX',
452     'REGR_SXY',
453     'REGR_SYY',
454     'RELEASE',
455     'RETURN',
456     'RETURNING_VALUES',
457     'RETURNS',
458     'REVOKE',
459     'RIGHT',
460     'ROLLBACK',
461     'ROW',
462 tony 263 'ROWS',
463 tony 47 'ROW_COUNT',
464     'SAVEPOINT',
465     'SCROLL',
466     'SECOND',
467     'SELECT',
468     'SENSITIVE',
469     'SET',
470     'SIMILAR',
471     'SMALLINT',
472     'SOME',
473     'SQLCODE',
474     'SQLSTATE',
475     'START',
476     'STDDEV_POP',
477     'STDDEV_SAMP',
478     'SUM',
479     'TABLE',
480     'THEN',
481     'TIME',
482     'TIMESTAMP',
483     'TO',
484     'TRAILING',
485     'TRIGGER',
486     'TRIM',
487     'TRUE',
488     'UNION',
489     'UNIQUE',
490     'UNKNOWN',
491     'UPDATE',
492     'UPDATING',
493     'UPPER',
494     'USER',
495     'USING',
496     'VALUE',
497     'VALUES',
498     'VAR_POP',
499     'VAR_SAMP',
500     'VARCHAR',
501     'VARIABLE',
502     'VARYING',
503     'VIEW',
504     'WHEN',
505     'WHERE',
506     'WHILE',
507     'WITH',
508     'YEAR'
509     );
510 tony 45
511 tony 263 type
512     {The TSQLTokeniser class provides a common means to parse an SQL statement, or
513     even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
514     with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
515     is instantiated with a stream from which the SQL statements are read.
516    
517     Successive calls to GetNextToken then return each SQL token. The TokenText contains
518     either the single character, the identifier or reserved word, the string or comment.}
519    
520     { TSQLTokeniser }
521    
522     TSQLTokeniser = class
523     private
524     const
525     TokenQueueMaxSize = 64;
526     type
527     TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
528     stInIdentifier, stInNumeric);
529    
530     TTokenQueueItem = record
531     token: TSQLTokens;
532     text: AnsiString;
533     end;
534     TTokenQueueState = (tsHold, tsRelease);
535    
536     private
537     FLastChar: AnsiChar;
538     FState: TLexState;
539     FSkipNext: boolean;
540     function GetNext: TSQLTokens;
541    
542     {The token Queue is available for use by descendents so that they can
543     hold back tokens in order to lookahead by token rather than just a single
544     character}
545    
546     private
547     FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
548     FQueueState: TTokenQueueState;
549     FQFirst: integer; {first and last pointers first=last => queue empty}
550     FQLast: integer;
551     FEOF: boolean;
552     procedure PopQueue(var token: TSQLTokens);
553     protected
554     FString: AnsiString;
555     FNextToken: TSQLTokens;
556     procedure Assign(source: TSQLTokeniser); virtual;
557     function GetChar: AnsiChar; virtual; abstract;
558     function TokenFound(var token: TSQLTokens): boolean; virtual;
559     function InternalGetNextToken: TSQLTokens; virtual;
560     procedure Reset; virtual;
561    
562     {Token stack}
563     procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
564     procedure QueueToken(token: TSQLTokens); overload;
565     procedure ResetQueue; overload;
566     procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
567     procedure ResetQueue(token: TSQLTokens); overload;
568     procedure ReleaseQueue(var token: TSQLTokens); overload;
569     procedure ReleaseQueue; overload;
570     function GetQueuedText: AnsiString;
571     procedure SetTokenText(text: AnsiString);
572    
573     public
574     const
575     DefaultTerminator = ';';
576     public
577     constructor Create;
578     destructor Destroy; override;
579     function GetNextToken: TSQLTokens;
580     property EOF: boolean read FEOF;
581     property TokenText: AnsiString read FString;
582     end;
583    
584     { TSQLwithNamedParamsTokeniser }
585    
586     TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
587     private
588     type
589     TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
590     private
591     FState: TSQLState;
592     FNested: integer;
593     protected
594     procedure Assign(source: TSQLTokeniser); override;
595     procedure Reset; override;
596     function TokenFound(var token: TSQLTokens): boolean; override;
597     end;
598    
599 tony 270 { TSQLParamProcessor }
600    
601     TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
602     private
603     const
604     sIBXParam = 'IBXParam'; {do not localize}
605     private
606     FInString: AnsiString;
607     FIndex: integer;
608     function DoExecute(GenerateParamNames: boolean;
609     var slNames: TStrings): AnsiString;
610     protected
611     function GetChar: AnsiChar; override;
612     public
613     class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
614     var slNames: TStrings): AnsiString;
615     end;
616    
617    
618 tony 45 function Max(n1, n2: Integer): Integer;
619     function Min(n1, n2: Integer): Integer;
620 tony 56 function RandomString(iLength: Integer): AnsiString;
621 tony 45 function RandomInteger(iLow, iHigh: Integer): Integer;
622 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
623     function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624 tony 263 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
625     function IsReservedWord(w: AnsiString): boolean;
626 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
627     function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
628     function Space2Underscore(s: AnsiString): AnsiString;
629     function SQLSafeString(const s: AnsiString): AnsiString;
630 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
631 tony 117 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
632 tony 143 function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
633     PortNo: AnsiString = ''): AnsiString;
634     function ParseConnectString(ConnectString: AnsiString;
635     var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
636     var PortNo: AnsiString): boolean;
637     function GetProtocol(ConnectString: AnsiString): TProtocolAll;
638 tony 45
639 tony 315 {$IF declared(TFormatSettings)}
640     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
641     var aTimezone: AnsiString; aFormatSettings: TFormatSettings; TimeOnly: boolean=false): boolean; overload;
642     {$IFEND}
643     function ParseDateTimeTZString(aDateTimeStr: Ansistring; var aDateTime: TDateTime;
644     var aTimezone: AnsiString; TimeOnly: boolean=false): boolean; overload;
645     procedure FBDecodeTime(aTime: TDateTime; var Hour, Minute, Second: word; var DeciMillisecond: cardinal);
646     function FBEncodeTime(Hour, Minute, Second, DeciMillisecond: cardinal): TDateTime;
647     function FBFormatDateTime(fmt: AnsiString; aDateTime: TDateTime): AnsiString;
648     function FormatTimeZoneOffset(EffectiveTimeOffsetMins: integer): AnsiString;
649     function DecodeTimeZoneOffset(TZOffset: AnsiString; var dstOffset: integer): boolean;
650     function StripLeadingZeros(Value: AnsiString): AnsiString;
651 tony 353 function TryStrToNumeric(S: Ansistring; out Value: int64; out scale: integer): boolean;
652     function NumericToDouble(aValue: Int64; aScale: integer): double;
653 tony 315
654 tony 353
655 tony 45 implementation
656    
657 tony 353 uses FBMessages, Math
658 tony 263
659 tony 315 {$IFDEF FPC}
660 tony 263 ,RegExpr
661 tony 315 {$ELSE}
662     {$IF declared(CompilerVersion) and (CompilerVersion >= 22)}
663     , RegularExpressions
664     {$IFEND}
665 tony 263 {$ENDIF};
666 tony 117
667 tony 315
668 tony 45 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 tony 56 function RandomString(iLength: Integer): AnsiString;
685 tony 45 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 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
699 tony 45 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 tony 117 {Extracts SQL Identifier typically from a Dialect 3 encoding}
710 tony 45
711 tony 117 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
712 tony 45 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 tony 263 {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 tony 117 {Returns true if "w" is a Firebird SQL reserved word}
752 tony 45
753 tony 56 function IsReservedWord(w: AnsiString): boolean;
754 tony 263 var token: TSQLTokens;
755 tony 45 begin
756 tony 263 Result := FindReservedWord(w,token);
757 tony 45 end;
758    
759 tony 117 {Format an SQL Identifier according to SQL Dialect}
760    
761 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
762 tony 45 begin
763 tony 311 Value := TrimRight(Value);
764 tony 45 if Dialect = 1 then
765 tony 311 Value := AnsiUpperCase(Value)
766 tony 45 else
767 tony 117 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
768 tony 45 Result := Value;
769     end;
770    
771 tony 107 const
772     ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
773    
774 tony 117 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
775    
776 tony 107 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 tony 315 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 tony 117 {Extracts the Database Connect string from a Create Database Statement}
805    
806 tony 315 {$IF declared(TRegexpr)}
807 tony 117 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 tony 143 ConnectString := RegexObj.Match[2];
820 tony 117 finally
821     RegexObj.Free;
822     end;
823     end;
824 tony 143
825     function ParseConnectString(ConnectString: AnsiString; var ServerName,
826     DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
827     ): boolean;
828 tony 231
829 tony 143 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 tony 231 RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
840 tony 143 Result := RegexObj.Exec(ConnectString);
841     if Result then
842     begin
843     {URL type connect string}
844 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
845 tony 143 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 tony 231 if ServerName = '' then
850     DatabaseName := '/' + DatabaseName;
851 tony 143 end
852     else
853     begin
854 tony 231 {URL type connect string - local loop}
855     RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
856 tony 143 Result := RegexObj.Exec(ConnectString);
857     if Result then
858 tony 231 begin
859 tony 315 Protocol := SchemeToProtocol(RegexObj.Match[1]);
860 tony 231 DatabaseName := RegexObj.Match[2];
861     end
862 tony 143 else
863     begin
864 tony 231 RegexObj.Expression := '^([a-zA-Z]:\\.*)';
865 tony 143 Result := RegexObj.Exec(ConnectString);
866     if Result then
867 tony 231 Protocol := Local {Windows with leading drive ID}
868 tony 143 else
869     begin
870 tony 231 RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
871 tony 143 Result := RegexObj.Exec(ConnectString);
872     if Result then
873     begin
874 tony 231 {Legacy TCP Format}
875 tony 143 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 tony 231 Protocol := TCP;
880 tony 143 end
881     else
882     begin
883 tony 231 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 tony 143 end;
900     end;
901     end;
902     end;
903     finally
904     RegexObj.Free;
905     end;
906     end;
907    
908 tony 315 {$ELSE}
909     {$IF declared(TRegex)}
910     function ExtractConnectString(const CreateSQL: AnsiString;
911     var ConnectString: AnsiString): boolean;
912     var Regex: TRegEx;
913     Match: TMatch;
914 tony 143 begin
915 tony 315 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 tony 143 end;
922    
923 tony 315 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 tony 118 {$ELSE}
998 tony 315 {cruder version of above for Delphi < XE. Older versions lack regular expression
999 tony 121 handling.}
1000 tony 118 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 tony 143
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 tony 315 {$IFEND}
1027     {$IFEND}
1028 tony 117
1029 tony 315 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 tony 143 {Make a connect string in format appropriate protocol}
1039    
1040     function MakeConnectString(ServerName, DatabaseName: AnsiString;
1041     Protocol: TProtocol; PortNo: AnsiString): AnsiString;
1042 tony 231
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 tony 143 begin
1052 tony 315 if ServerName = '' then ServerName := 'localhost';
1053 tony 143 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 tony 231 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 tony 143 end;
1077     end;
1078    
1079 tony 117 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
1080    
1081 tony 56 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
1082 tony 45 begin
1083 tony 311 Value := TrimRight(Value);
1084 tony 45 if (Dialect = 3) and
1085 tony 115 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
1086 tony 117 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
1087 tony 45 else
1088     Result := Value
1089     end;
1090    
1091 tony 117 {Replaces unknown characters in a string with underscores}
1092    
1093 tony 56 function Space2Underscore(s: AnsiString): AnsiString;
1094 tony 45 var
1095     k: integer;
1096     begin
1097     Result := s;
1098     for k := 1 to Length(s) do
1099 tony 117 if not (Result[k] in ValidSQLIdentifierChars) then
1100 tony 45 Result[k] := '_';
1101     end;
1102    
1103 tony 117 {Reformats an SQL string with single quotes duplicated.}
1104    
1105 tony 56 function SQLSafeString(const s: AnsiString): AnsiString;
1106 tony 47 begin
1107     Result := StringReplace(s,'''','''''',[rfReplaceAll]);
1108     end;
1109 tony 45
1110 tony 270 { 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 tony 287 Result := Result + '--' + TokenText + LineEnding;
1153 tony 270
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 tony 263 { 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 tony 348 sqltBegin,
1256     sqltCase:
1257 tony 263 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 tony 270 '\':
1308     Result := sqltBackslash;
1309 tony 263 '*':
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 tony 287 '-':
1328     Result := sqltMinus;
1329 tony 263 '<':
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 tony 353 if FSkipNext then
1479     begin
1480     FSkipNext := false;
1481     GetNext;
1482     end;
1483    
1484 tony 263 Result := FNextToken;
1485     C := FLastChar;
1486     GetNext;
1487    
1488 tony 353 if (Result = sqltCR) and (FNextToken = sqltEOL) then
1489 tony 263 begin
1490 tony 353 FSkipNext := true;
1491     Result := sqltEOL;
1492     C := LF;
1493 tony 263 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 tony 353 if Result = sqltEOL then
1506     FString := FString + LineEnding
1507     else
1508 tony 263 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 tony 353 if Result = sqltEOL then
1542     FString := FString + LineEnding
1543     else
1544 tony 263 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 tony 353 if Result = sqltEOL then
1564     FString := FString + LineEnding
1565     else
1566 tony 263 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 tony 287 end;
1616    
1617     sqltMinus:
1618     begin
1619     if FNextToken = sqltMinus then
1620 tony 263 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 tony 265 if FNextToken in [sqltIdentifier,sqltNumberString] then
1641 tony 263 FState := stInIdentifier;
1642    
1643     sqltNumberString:
1644     if FNextToken in [sqltNumberString,sqltPeriod] then
1645     FState := stInNumeric;
1646 tony 353
1647     sqltEOL:
1648     FString := LineEnding;
1649 tony 263 end;
1650     end;
1651     end;
1652    
1653     // writeln(FString);
1654     FEOF := Result = sqltEOF;
1655     until TokenFound(Result) or EOF;
1656     end;
1657    
1658 tony 315 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 tony 353 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     for i := length(S) downto 1 do
1868     begin
1869     if S[i] = AnsiChar(DecimalSeparator) then
1870     begin
1871     if ds <> 0 then Exit; {only one allowed}
1872 tony 356 ds := i;
1873 tony 353 dec(exponent);
1874     system.Delete(S,i,1);
1875     end
1876     else
1877 tony 354 if S[i] in ['+','-'] then
1878     begin
1879     if (i > 1) and not (S[i-1] in ['e','E']) then
1880     Exit; {malformed}
1881     end
1882 tony 353 else
1883     if S[i] in ['e','E'] then {scientific notation}
1884     begin
1885     if ds <> 0 then Exit; {not permitted in exponent}
1886     if exponent <> 0 then Exit; {only one allowed}
1887     exponent := i;
1888     end
1889     else
1890     if not (S[i] in ['0'..'9']) then
1891 tony 356 {Note: ThousandSeparator not allowed by Delphi specs}
1892 tony 353 Exit; {bad character}
1893     end;
1894    
1895     if exponent > 0 then
1896     begin
1897     Result := TryStrToInt(system.copy(S,exponent+1,maxint),Scale);
1898     if Result then
1899     begin
1900     {adjust scale for decimal point}
1901 tony 356 if ds <> 0 then
1902     Scale := Scale - (exponent - ds);
1903 tony 353 Result := TryStrToInt64(system.copy(S,1,exponent-1),Value);
1904     end;
1905     end
1906     else
1907     begin
1908     if ds <> 0 then
1909 tony 356 scale := ds - Length(S) - 1;
1910 tony 353 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 tony 45 end.