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

Comparing ibx/trunk/fbintf/IBUtils.pas (file contents):
Revision 47 by tony, Mon Jan 9 15:31:51 2017 UTC vs.
Revision 270 by tony, Fri Jan 18 11:10:37 2019 UTC

# Line 32 | Line 32
32   {************************************************************************}
33  
34   unit IBUtils;
35 + {$IFDEF MSWINDOWS}
36 + {$DEFINE WINDOWS}
37 + {$ENDIF}
38  
39   {$IFDEF FPC}
40   {$Mode Delphi}
41   {$codepage UTF8}
42 + {$define HASREQEX}
43   {$ENDIF}
44  
45 +
46   interface
47  
48 < uses
49 < {$IFDEF WINDOWS }
50 <  Windows,
51 < {$ELSE}
52 <  unix,
53 < {$ENDIF}
54 <  Classes, SysUtils;
48 > uses Classes, SysUtils, IB;
49 >
50 > type
51 >  TSQLTokens = (
52 >
53 >  {Reserved Words}
54 >
55 >  sqltAdd,
56 >  sqltAdmin,
57 >  sqltAll,
58 >  sqltAlter,
59 >  sqltAnd,
60 >  sqltAny,
61 >  sqltAs,
62 >  sqltAt,
63 >  sqltAvg,
64 >  sqltBegin,
65 >  sqltBetween,
66 >  sqltBigint,
67 >  sqltBit_Length,
68 >  sqltBlob,
69 >  sqltBoolean,
70 >  sqltBoth,
71 >  sqltBy,
72 >  sqltCase,
73 >  sqltCast,
74 >  sqltChar,
75 >  sqltChar_Length,
76 >  sqltCharacter,
77 >  sqltCharacter_Length,
78 >  sqltCheck,
79 >  sqltClose,
80 >  sqltCollate,
81 >  sqltColumn,
82 >  sqltCommit,
83 >  sqltConnect,
84 >  sqltConstraint,
85 >  sqltCorr,
86 >  sqltCount,
87 >  sqltCovar_Pop,
88 >  sqltCovar_Samp,
89 >  sqltCreate,
90 >  sqltCross,
91 >  sqltCurrent,
92 >  sqltCurrent_Connection,
93 >  sqltCurrent_Date,
94 >  sqltCurrent_Role,
95 >  sqltCurrent_Time,
96 >  sqltCurrent_Timestamp,
97 >  sqltCurrent_Transaction,
98 >  sqltCurrent_User,
99 >  sqltCursor,
100 >  sqltDate,
101 >  sqltDay,
102 >  sqltDec,
103 >  sqltDecimal,
104 >  sqltDeclare,
105 >  sqltDefault,
106 >  sqltDelete,
107 >  sqltDeleting,
108 >  sqltDeterministic,
109 >  sqltDisconnect,
110 >  sqltDistinct,
111 >  sqltDouble,
112 >  sqltDrop,
113 >  sqltElse,
114 >  sqltEnd,
115 >  sqltEscape,
116 >  sqltExecute,
117 >  sqltExists,
118 >  sqltExternal,
119 >  sqltExtract,
120 >  sqltFalse,
121 >  sqltFetch,
122 >  sqltFilter,
123 >  sqltFloat,
124 >  sqltFor,
125 >  sqltForeign,
126 >  sqltFrom,
127 >  sqltFull,
128 >  sqltFunction,
129 >  sqltGdscode,
130 >  sqltGlobal,
131 >  sqltGrant,
132 >  sqltGroup,
133 >  sqltHaving,
134 >  sqltHour,
135 >  sqltIn,
136 >  sqltIndex,
137 >  sqltInner,
138 >  sqltInsensitive,
139 >  sqltInsert,
140 >  sqltInserting,
141 >  sqltInt,
142 >  sqltInteger,
143 >  sqltInto,
144 >  sqltIs,
145 >  sqltJoin,
146 >  sqltKey,
147 >  sqltLeading,
148 >  sqltLeft,
149 >  sqltLike,
150 >  sqltLong,
151 >  sqltLower,
152 >  sqltMax,
153 >  sqltMaximum_Segment,
154 >  sqltMerge,
155 >  sqltMin,
156 >  sqltMinute,
157 >  sqltMonth,
158 >  sqltNational,
159 >  sqltNatural,
160 >  sqltNchar,
161 >  sqltNo,
162 >  sqltNot,
163 >  sqltNull,
164 >  sqltNumeric,
165 >  sqltOctet_Length,
166 >  sqltOf,
167 >  sqltOffset,
168 >  sqltOn,
169 >  sqltOnly,
170 >  sqltOpen,
171 >  sqltOr,
172 >  sqltOrder,
173 >  sqltOuter,
174 >  sqltOver,
175 >  sqltParameter,
176 >  sqltPlan,
177 >  sqltPosition,
178 >  sqltPost_Event,
179 >  sqltPrecision,
180 >  sqltPrimary,
181 >  sqltProcedure,
182 >  sqltRdbDb_Key,
183 >  sqltRdbRecord_Version,
184 >  sqltReal,
185 >  sqltRecord_Version,
186 >  sqltRecreate,
187 >  sqltRecursive,
188 >  sqltReferences,
189 >  sqltRegr_Avgx,
190 >  sqltRegr_Avgy,
191 >  sqltRegr_Count,
192 >  sqltRegr_Intercept,
193 >  sqltRegr_R2,
194 >  sqltRegr_Slope,
195 >  sqltRegr_Sxx,
196 >  sqltRegr_Sxy,
197 >  sqltRegr_Syy,
198 >  sqltRelease,
199 >  sqltReturn,
200 >  sqltReturning_Values,
201 >  sqltReturns,
202 >  sqltRevoke,
203 >  sqltRight,
204 >  sqltRollback,
205 >  sqltRow,
206 >  sqltRows,
207 >  sqltRow_Count,
208 >  sqltSavepoint,
209 >  sqltScroll,
210 >  sqltSecond,
211 >  sqltSelect,
212 >  sqltSensitive,
213 >  sqltSet,
214 >  sqltSimilar,
215 >  sqltSmallint,
216 >  sqltSome,
217 >  sqltSqlcode,
218 >  sqltSqlstate,
219 >  sqltStart,
220 >  sqltStddev_Pop,
221 >  sqltStddev_Samp,
222 >  sqltSum,
223 >  sqltTable,
224 >  sqltThen,
225 >  sqltTime,
226 >  sqltTimestamp,
227 >  sqltTo,
228 >  sqltTrailing,
229 >  sqltTrigger,
230 >  sqltTrim,
231 >  sqltTrue,
232 >  sqltUnion,
233 >  sqltUnique,
234 >  sqltUnknown,
235 >  sqltUpdate,
236 >  sqltUpdating,
237 >  sqltUpper,
238 >  sqltUser,
239 >  sqltUsing,
240 >  sqltValue,
241 >  sqltValues,
242 >  sqltVar_Pop,
243 >  sqltVar_Samp,
244 >  sqltVarchar,
245 >  sqltVariable,
246 >  sqltVarying,
247 >  sqltView,
248 >  sqltWhen,
249 >  sqltWhere,
250 >  sqltWhile,
251 >  sqltWith,
252 >  sqltYear,
253 >
254 >  {symbols}
255 >
256 >  sqltSpace,
257 >  sqltSemiColon,
258 >  sqltPlaceholder,
259 >  sqltSingleQuotes,
260 >  sqltDoubleQuotes,
261 >  sqltBackslash,
262 >  sqltComma,
263 >  sqltPeriod,
264 >  sqltEquals,
265 >  sqltOtherCharacter,
266 >  sqltIdentifier,
267 >  sqltIdentifierInDoubleQuotes,
268 >  sqltNumberString,
269 >  sqltString,
270 >  sqltParam,
271 >  sqltQuotedParam,
272 >  sqltColon,
273 >  sqltComment,
274 >  sqltCommentLine,
275 >  sqltQuotedString,
276 >  sqltAsterisk,
277 >  sqltForwardSlash,
278 >  sqltOpenSquareBracket,
279 >  sqltCloseSquareBracket,
280 >  sqltOpenBracket,
281 >  sqltCloseBracket,
282 >  sqltPipe,
283 >  sqltConcatSymbol,
284 >  sqltLT,
285 >  sqltGT,
286 >  sqltCR,
287 >  sqltEOL,
288 >  sqltEOF,
289 >  sqltInit
290 >  );
291 >
292 >  TSQLReservedWords = sqltAdd..sqltYear;
293  
294   const
295    CRLF = #13 + #10;
# Line 55 | Line 298 | const
298    TAB  = #9;
299    NULL_TERMINATOR = #0;
300  
301 <  sqlReservedWords: array [0..197] of string = (
301 >  {$IFNDEF FPC}
302 >  LineEnding = CRLF;
303 >  {$ENDIF}
304 >
305 >  {SQL Reserved words in alphabetical order}
306 >
307 >  sqlReservedWords: array [TSQLReservedWords] of string = (
308    'ADD',
309    'ADMIN',
310    'ALL',
# Line 147 | Line 396 | const
396    'INTO',
397    'IS',
398    'JOIN',
399 +  'KEY',
400    'LEADING',
401    'LEFT',
402    'LIKE',
# Line 206 | Line 456 | const
456    'RIGHT',
457    'ROLLBACK',
458    'ROW',
209 –  'ROW_COUNT',
459    'ROWS',
460 +  'ROW_COUNT',
461    'SAVEPOINT',
462    'SCROLL',
463    'SECOND',
# Line 219 | Line 469 | const
469    'SOME',
470    'SQLCODE',
471    'SQLSTATE',
222 –  'SQLSTATE',
472    'START',
473    'STDDEV_POP',
474    'STDDEV_SAMP',
# Line 256 | Line 505 | const
505    'YEAR'
506    );
507  
508 + type
509 +  {The TSQLTokeniser class provides a common means to parse an SQL statement, or
510 +   even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
511 +   with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
512 +   is instantiated with a stream from which the SQL statements are read.
513 +
514 +   Successive calls to GetNextToken then return each SQL token. The TokenText contains
515 +   either the single character, the identifier or reserved word, the string or comment.}
516 +
517 +  { TSQLTokeniser }
518 +
519 +  TSQLTokeniser = class
520 +  private
521 +    const
522 +      TokenQueueMaxSize = 64;
523 +    type
524 +      TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
525 +                   stInIdentifier, stInNumeric);
526 +
527 +      TTokenQueueItem = record
528 +                          token: TSQLTokens;
529 +                          text: AnsiString;
530 +                        end;
531 +      TTokenQueueState = (tsHold, tsRelease);
532 +
533 +  private
534 +    FLastChar: AnsiChar;
535 +    FState: TLexState;
536 +    FSkipNext: boolean;
537 +    function GetNext: TSQLTokens;
538 +
539 +    {The token Queue is available for use by descendents so that they can
540 +     hold back tokens in order to lookahead by token rather than just a single
541 +     character}
542 +
543 +  private
544 +    FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
545 +    FQueueState: TTokenQueueState;
546 +    FQFirst: integer;  {first and last pointers first=last => queue empty}
547 +    FQLast: integer;
548 +    FEOF: boolean;
549 +    procedure PopQueue(var token: TSQLTokens);
550 +  protected
551 +    FString: AnsiString;
552 +    FNextToken: TSQLTokens;
553 +    procedure Assign(source: TSQLTokeniser); virtual;
554 +    function GetChar: AnsiChar; virtual; abstract;
555 +    function TokenFound(var token: TSQLTokens): boolean; virtual;
556 +    function InternalGetNextToken: TSQLTokens; virtual;
557 +    procedure Reset; virtual;
558 +
559 +    {Token stack}
560 +    procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
561 +    procedure QueueToken(token: TSQLTokens); overload;
562 +    procedure ResetQueue; overload;
563 +    procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
564 +    procedure ResetQueue(token: TSQLTokens); overload;
565 +    procedure ReleaseQueue(var token: TSQLTokens); overload;
566 +    procedure ReleaseQueue; overload;
567 +    function GetQueuedText: AnsiString;
568 +    procedure SetTokenText(text: AnsiString);
569 +
570 +  public
571 +    const
572 +        DefaultTerminator = ';';
573 +  public
574 +    constructor Create;
575 +    destructor Destroy; override;
576 +    function GetNextToken: TSQLTokens;
577 +    property EOF: boolean read FEOF;
578 +    property TokenText: AnsiString read FString;
579 +  end;
580 +
581 +  { TSQLwithNamedParamsTokeniser }
582 +
583 +  TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
584 +  private
585 +    type
586 +      TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
587 +  private
588 +    FState: TSQLState;
589 +    FNested: integer;
590 +  protected
591 +    procedure Assign(source: TSQLTokeniser); override;
592 +    procedure Reset; override;
593 +    function TokenFound(var token: TSQLTokens): boolean; override;
594 +  end;
595 +
596 +    { TSQLParamProcessor }
597 +
598 +  TSQLParamProcessor = class(TSQLwithNamedParamsTokeniser)
599 +  private
600 +  const
601 +    sIBXParam = 'IBXParam';  {do not localize}
602 +  private
603 +    FInString: AnsiString;
604 +    FIndex: integer;
605 +    function DoExecute(GenerateParamNames: boolean;
606 +        var slNames: TStrings): AnsiString;
607 +  protected
608 +    function GetChar: AnsiChar; override;
609 +  public
610 +    class function Execute(sSQL: AnsiString; GenerateParamNames: boolean;
611 +        var slNames: TStrings): AnsiString;
612 +  end;
613 +
614 +
615   function Max(n1, n2: Integer): Integer;
616   function Min(n1, n2: Integer): Integer;
617 < function RandomString(iLength: Integer): String;
617 > function RandomString(iLength: Integer): AnsiString;
618   function RandomInteger(iLow, iHigh: Integer): Integer;
619 < function StripString(st: String; CharsToStrip: String): String;
620 < function FormatIdentifier(Dialect: Integer; Value: String): String;
621 < function FormatIdentifierValue(Dialect: Integer; Value: String): String;
622 < function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
623 < function ExtractIdentifier(Dialect: Integer; Value: String): String;
624 < function QuoteIdentifier(Dialect: Integer; Value: String): String;
625 < function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
626 < function Space2Underscore(s: string): string;
627 < function SQLSafeString(const s: string): string;
619 > function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
620 > function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
621 > function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
622 > function IsReservedWord(w: AnsiString): boolean;
623 > function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
624 > function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
625 > function Space2Underscore(s: AnsiString): AnsiString;
626 > function SQLSafeString(const s: AnsiString): AnsiString;
627 > function IsSQLIdentifier(Value: AnsiString): boolean;
628 > function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
629 > function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
630 >              PortNo: AnsiString = ''): AnsiString;
631 > function ParseConnectString(ConnectString: AnsiString;
632 >              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
633 >              var PortNo: AnsiString): boolean;
634 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
635  
636   implementation
637  
638 + uses FBMessages
639 +
640 + {$IFDEF HASREQEX}
641 + ,RegExpr
642 + {$ENDIF};
643 +
644   function Max(n1, n2: Integer): Integer;
645   begin
646    if (n1 > n2) then
# Line 288 | Line 657 | begin
657      result := n2;
658   end;
659  
660 < function RandomString(iLength: Integer): String;
660 > function RandomString(iLength: Integer): AnsiString;
661   begin
662    result := '';
663    while Length(result) < iLength do
# Line 302 | Line 671 | begin
671    result := Trunc(Random(iHigh - iLow)) + iLow;
672   end;
673  
674 < function StripString(st: String; CharsToStrip: String): String;
674 > function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
675   var
676    i: Integer;
677   begin
# Line 313 | Line 682 | begin
682    end;
683   end;
684  
685 < function FormatIdentifier(Dialect: Integer; Value: String): String;
317 < begin
318 <  Value := Trim(Value);
319 <  if Dialect = 1 then
320 <    Value := AnsiUpperCase(Value)
321 <  else
322 <    if (Value <> '') and (Value[1] = '"') then
323 <      Value := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
324 <    else
325 <      Value := AnsiUpperCase(Value);
326 <  Result := Value;
327 < end;
685 > {Extracts SQL Identifier typically from a  Dialect 3 encoding}
686  
687 < function FormatIdentifierValue(Dialect: Integer; Value: String): String;
687 > function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
688   begin
689    Value := Trim(Value);
690    if Dialect = 1 then
# Line 345 | Line 703 | begin
703    Result := Value;
704   end;
705  
706 < function FormatIdentifierValueNC(Dialect: Integer; Value: String): String;
706 > {Returns true if "w" is a Firebird SQL reserved word, and the
707 > corresponding TSQLTokens value.}
708 >
709 > function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
710 > var i: TSQLTokens;
711 > begin
712 >   Result := true;
713 >   w := AnsiUpperCase(Trim(w));
714 >   for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
715 >   begin
716 >       if w = sqlReservedWords[i] then
717 >       begin
718 >         token := i;
719 >         Exit;
720 >       end;
721 >       if w <  sqlReservedWords[i] then
722 >         break;
723 >   end;
724 >   Result := false;
725 > end;
726 >
727 > {Returns true if "w" is a Firebird SQL reserved word}
728 >
729 > function IsReservedWord(w: AnsiString): boolean;
730 > var token: TSQLTokens;
731 > begin
732 >  Result := FindReservedWord(w,token);
733 > end;
734 >
735 > {Format an SQL Identifier according to SQL Dialect}
736 >
737 > function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
738   begin
350 –  Value := Trim(Value);
739    if Dialect = 1 then
740 <    Value := AnsiUpperCase(Value)
740 >    Value := AnsiUpperCase(Trim(Value))
741    else
742 +    Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
743 +  Result := Value;
744 + end;
745 +
746 + const
747 +  ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
748 +
749 + {Returns true if the value is a valid SQL Identifier - note lower case accepted}
750 +
751 + function IsSQLIdentifier(Value: AnsiString): boolean;
752 + var i: integer;
753 + begin
754 +  Result := false;
755 +  for i := 1 to Length(Value) do
756 +    if not (Value[i] in ValidSQLIdentifierChars) then Exit;
757 +  Result := true;
758 + end;
759 +
760 + {Extracts the Database Connect string from a Create Database Statement}
761 +
762 + {$IFDEF HASREQEX}
763 + function ExtractConnectString(const CreateSQL: AnsiString;
764 +  var ConnectString: AnsiString): boolean;
765 + var RegexObj: TRegExpr;
766 + begin
767 +  RegexObj := TRegExpr.Create;
768 +  try
769 +    {extact database file spec}
770 +    RegexObj.ModifierG := false; {turn off greedy matches}
771 +    RegexObj.ModifierI := true; {case insensitive match}
772 +    RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
773 +    Result := RegexObj.Exec(CreateSQL);
774 +    if Result then
775 +      ConnectString := RegexObj.Match[2];
776 +  finally
777 +    RegexObj.Free;
778 +  end;
779 + end;
780 +
781 + function ParseConnectString(ConnectString: AnsiString; var ServerName,
782 +  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
783 +  ): boolean;
784 +
785 +  function GetProtocol(scheme: AnsiString): TProtocolAll;
786    begin
787 <    if (Value <> '') and (Value[1] = '"') then
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 > var RegexObj: TRegExpr;
805 > begin
806 >  ServerName := '';
807 >  DatabaseName := ConnectString;
808 >  PortNo := '';
809 >  Protocol := unknownProtocol;
810 >  RegexObj := TRegExpr.Create;
811 >  try
812 >    {extact database file spec}
813 >    RegexObj.ModifierG := false; {turn off greedy matches}
814 >    RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
815 >    Result := RegexObj.Exec(ConnectString);
816 >    if Result then
817      begin
818 <      Delete(Value, 1, 1);
819 <      Delete(Value, Length(Value), 1);
820 <      Value := AnsiUpperCase(StringReplace (Value, '""', '"', [rfReplaceAll]));
818 >      {URL type connect string}
819 >      Protocol := GetProtocol(RegexObj.Match[1]);
820 >      ServerName := RegexObj.Match[2];
821 >      if RegexObj.MatchLen[3] > 0 then
822 >        PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
823 >      DatabaseName := RegexObj.Match[4];
824 >      if ServerName = '' then
825 >        DatabaseName := '/' + DatabaseName;
826      end
827      else
828 <      Value := AnsiUpperCase(Value);
828 >    begin
829 >      {URL type connect string - local loop}
830 >      RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
831 >      Result := RegexObj.Exec(ConnectString);
832 >      if Result then
833 >      begin
834 >        Protocol := GetProtocol(RegexObj.Match[1]);
835 >        DatabaseName := RegexObj.Match[2];
836 >      end
837 >      else
838 >      begin
839 >        RegexObj.Expression := '^([a-zA-Z]:\\.*)';
840 >        Result := RegexObj.Exec(ConnectString);
841 >        if Result then
842 >          Protocol := Local {Windows with leading drive ID}
843 >        else
844 >        begin
845 >          RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
846 >          Result := RegexObj.Exec(ConnectString);
847 >          if Result then
848 >          begin
849 >            {Legacy TCP Format}
850 >            ServerName := RegexObj.Match[1];
851 >            if RegexObj.MatchLen[2] > 0 then
852 >              PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
853 >            DatabaseName := RegexObj.Match[3];
854 >            Protocol := TCP;
855 >          end
856 >          else
857 >          begin
858 >            RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
859 >            Result := RegexObj.Exec(ConnectString);
860 >            if Result then
861 >            begin
862 >              {Netbui}
863 >              ServerName := RegexObj.Match[1];
864 >              if RegexObj.MatchLen[2] > 0 then
865 >                PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
866 >              DatabaseName := RegexObj.Match[3];
867 >              Protocol := NamedPipe
868 >            end
869 >            else
870 >            begin
871 >              Result := true;
872 >              Protocol := Local; {Assume local}
873 >            end;
874 >          end;
875 >        end;
876 >      end;
877 >    end;
878 >  finally
879 >    RegexObj.Free;
880    end;
364 –  Result := Value;
881   end;
882  
883 < function ExtractIdentifier(Dialect: Integer; Value: String): String;
883 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
884 > var ServerName,
885 >    DatabaseName: AnsiString;
886 >    PortNo: AnsiString;
887   begin
888 <  Value := Trim(Value);
889 <  if Dialect = 1 then
890 <    Value := AnsiUpperCase(Value)
891 <  else
888 >  ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
889 > end;
890 >
891 > {$ELSE}
892 > {cruder version of above for Delphi. Older versions lack regular expression
893 > handling.}
894 > function ExtractConnectString(const CreateSQL: AnsiString;
895 >  var ConnectString: AnsiString): boolean;
896 > var i: integer;
897 > begin
898 >  Result := false;
899 >  i := Pos('''',CreateSQL);
900 >  if i > 0 then
901    begin
902 <    if (Value <> '') and (Value[1] = '"') then
902 >    ConnectString := CreateSQL;
903 >    delete(ConnectString,1,i);
904 >    i := Pos('''',ConnectString);
905 >    if i > 0 then
906      begin
907 <      Delete(Value, 1, 1);
908 <      Delete(Value, Length(Value), 1);
909 <      Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
379 <    end
380 <    else
381 <      Value := AnsiUpperCase(Value);
907 >      delete(ConnectString,i,Length(ConnectString)-i+1);
908 >      Result := true;
909 >    end;
910    end;
383 –  Result := Value;
911   end;
912  
913 < function IsReservedWord(w: string): boolean;
387 < var i: integer;
913 > function GetProtocol(ConnectString: AnsiString): TProtocolAll;
914   begin
915 <     Result := true;
390 <     for i := 0 to Length(sqlReservedWords) - 1 do
391 <         if w = sqlReservedWords[i] then
392 <            Exit;
393 <     Result := false;
915 >  Result := unknownProtocol; {not implemented for Delphi}
916   end;
917  
918 < function QuoteIdentifier(Dialect: Integer; Value: String): String;
918 > function ParseConnectString(ConnectString: AnsiString;
919 >              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
920 >              var PortNo: AnsiString): boolean;
921   begin
922 <  if Dialect = 1 then
399 <    Value := AnsiUpperCase(Trim(Value))
400 <  else
401 <    Value := '"' + Value + '"';
402 <  Result := Value;
922 >  Result := false;
923   end;
924  
925 < function QuoteIdentifierIfNeeded(Dialect: Integer; Value: String): String;
925 > {$ENDIF}
926 >
927 > {Make a connect string in format appropriate protocol}
928 >
929 > function MakeConnectString(ServerName, DatabaseName: AnsiString;
930 >  Protocol: TProtocol; PortNo: AnsiString): AnsiString;
931 >
932 >  function FormatURL: AnsiString;
933 >  begin
934 >    if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
935 >      Result := DatabaseName
936 >    else
937 >      Result := ServerName + '/' + DatabaseName;
938 >  end;
939 >
940 > begin
941 >  if PortNo <> '' then
942 >    case Protocol of
943 >    NamedPipe:
944 >      ServerName := ServerName + '@' + PortNo;
945 >    Local,
946 >    SPX,
947 >    xnet: {do nothing};
948 >    TCP:
949 >      ServerName := ServerName + '/' + PortNo;
950 >    else
951 >      ServerName := ServerName + ':' + PortNo;
952 >    end;
953 >
954 >  case Protocol of
955 >    TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
956 >    SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
957 >    NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
958 >    Local:      Result := DatabaseName; {do not localize}
959 >    inet:       Result := 'inet://' + FormatURL; {do not localize}
960 >    inet4:       Result := 'inet4://' + FormatURL; {do not localize}
961 >    inet6:       Result := 'inet6://' + FormatURL; {do not localize}
962 >    wnet:       Result := 'wnet://' + FormatURL; {do not localize}
963 >    xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
964 >  end;
965 > end;
966 >
967 > {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
968 >
969 > function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
970   begin
971    if (Dialect = 3) and
972 <    ((AnsiUpperCase(Value) <> Value) or IsReservedWord(Value)) then
973 <     Result := '"' + Value + '"'
972 >    (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
973 >     Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
974    else
975      Result := Value
976   end;
977  
978 < function Space2Underscore(s: string): string;
978 > {Replaces unknown characters in a string with underscores}
979 >
980 > function Space2Underscore(s: AnsiString): AnsiString;
981   var
982     k: integer;
983   begin
984       Result := s;
985       for k := 1 to Length(s) do
986 <         if not (Result[k] in ['0'..'9','A'..'Z','_','$'])  then
986 >         if not (Result[k] in ValidSQLIdentifierChars)  then
987              Result[k] := '_';
988   end;
989  
990 < function SQLSafeString(const s: string): string;
990 > {Reformats an SQL string with single quotes duplicated.}
991 >
992 > function SQLSafeString(const s: AnsiString): AnsiString;
993   begin
994    Result := StringReplace(s,'''','''''',[rfReplaceAll]);
995   end;
996  
997 + { TSQLParamProcessor }
998 +
999 + function TSQLParamProcessor.DoExecute(GenerateParamNames: boolean;
1000 +  var slNames: TStrings): AnsiString;
1001 + var token: TSQLTokens;
1002 +    iParamSuffix: Integer;
1003 + begin
1004 +  Result := '';
1005 +  iParamSuffix := 0;
1006 +
1007 +  while not EOF do
1008 +  begin
1009 +    token := GetNextToken;
1010 +    case token of
1011 +    sqltParam,
1012 +    sqltQuotedParam:
1013 +      begin
1014 +        Result := Result + '?';
1015 +        slNames.Add(TokenText);
1016 +      end;
1017 +
1018 +    sqltPlaceHolder:
1019 +      if GenerateParamNames then
1020 +      begin
1021 +        Inc(iParamSuffix);
1022 +        slNames.AddObject(sIBXParam + IntToStr(iParamSuffix),self); //Note local convention
1023 +                                            //add pointer to self to mark entry
1024 +        Result := Result + '?';
1025 +      end
1026 +      else
1027 +        IBError(ibxeSQLParseError, [SParamNameExpected]);
1028 +
1029 +    sqltQuotedString:
1030 +      Result := Result + '''' + SQLSafeString(TokenText) + '''';
1031 +
1032 +    sqltIdentifierInDoubleQuotes:
1033 +      Result := Result + '"' + StringReplace(TokenText,'"','""',[rfReplaceAll]) + '"';
1034 +
1035 +    sqltComment:
1036 +      Result := Result + '/*' + TokenText + '*/';
1037 +
1038 +    sqltCommentLine:
1039 +      Result := Result + '//' + TokenText + LineEnding;
1040 +
1041 +    sqltEOL:
1042 +      Result := Result + LineEnding;
1043 +
1044 +    else
1045 +      Result := Result + TokenText;
1046 +    end;
1047 +  end;
1048 + end;
1049 +
1050 + function TSQLParamProcessor.GetChar: AnsiChar;
1051 + begin
1052 +  if FIndex <= Length(FInString) then
1053 +  begin
1054 +    Result := FInString[FIndex];
1055 +    Inc(FIndex);
1056 +  end
1057 +  else
1058 +    Result := #0;
1059 + end;
1060 +
1061 + class function TSQLParamProcessor.Execute(sSQL: AnsiString;
1062 +  GenerateParamNames: boolean; var slNames: TStrings): AnsiString;
1063 + begin
1064 +  with self.Create do
1065 +  try
1066 +    FInString := sSQL;
1067 +    FIndex := 1;
1068 +    Result := DoExecute(GenerateParamNames,slNames);
1069 +  finally
1070 +    Free;
1071 +  end;
1072 + end;
1073 +
1074 + { TSQLwithNamedParamsTokeniser }
1075 +
1076 + procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
1077 + begin
1078 +  inherited Assign(source);
1079 +  if source is TSQLwithNamedParamsTokeniser then
1080 +  begin
1081 +    FState := TSQLwithNamedParamsTokeniser(source).FState;
1082 +    FNested := TSQLwithNamedParamsTokeniser(source).FNested;
1083 +  end;
1084 + end;
1085 +
1086 + procedure TSQLwithNamedParamsTokeniser.Reset;
1087 + begin
1088 +  inherited Reset;
1089 +  FState := stInit;
1090 +  FNested := 0;
1091 + end;
1092 +
1093 + function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
1094 +  ): boolean;
1095 + begin
1096 +  Result := inherited TokenFound(token);
1097 +  if not Result then Exit;
1098 +
1099 +  case FState of
1100 +  stInit:
1101 +    begin
1102 +      case token of
1103 +      sqltColon:
1104 +        begin
1105 +          FState := stInParam;
1106 +          ResetQueue(token);
1107 +        end;
1108 +
1109 +      sqltBegin:
1110 +        begin
1111 +          FState := stInBlock;
1112 +          FNested := 1;
1113 +        end;
1114 +
1115 +      sqltOpenSquareBracket:
1116 +          FState := stInArrayDim;
1117 +
1118 +      end;
1119 +    end;
1120 +
1121 +  stInParam:
1122 +    begin
1123 +      case token of
1124 +      sqltIdentifier:
1125 +        token := sqltParam;
1126 +
1127 +      sqltIdentifierInDoubleQuotes:
1128 +        token := sqltQuotedParam;
1129 +
1130 +      else
1131 +        begin
1132 +          QueueToken(token);
1133 +          ReleaseQueue(token);
1134 +        end;
1135 +      end;
1136 +      FState := stInit;
1137 +    end;
1138 +
1139 +  stInBlock:
1140 +    begin
1141 +      case token of
1142 +      sqltBegin:
1143 +          Inc(FNested);
1144 +
1145 +      sqltEnd:
1146 +        begin
1147 +          Dec(FNested);
1148 +          if FNested = 0 then
1149 +            FState := stInit;
1150 +        end;
1151 +      end;
1152 +    end;
1153 +
1154 +    stInArrayDim:
1155 +      begin
1156 +        if token = sqltCloseSquareBracket then
1157 +            FState := stInit;
1158 +      end;
1159 +    end;
1160 +
1161 +  Result := (FState <> stInParam);
1162 + end;
1163 +
1164 + { TSQLTokeniser }
1165 +
1166 + function TSQLTokeniser.GetNext: TSQLTokens;
1167 + var C: AnsiChar;
1168 + begin
1169 +  if EOF then
1170 +    Result := sqltEOF
1171 +  else
1172 +  begin
1173 +    C := GetChar;
1174 +    case C of
1175 +    #0:
1176 +      Result := sqltEOF;
1177 +    ' ',TAB:
1178 +      Result := sqltSpace;
1179 +    '0'..'9':
1180 +      Result := sqltNumberString;
1181 +    ';':
1182 +      Result := sqltSemiColon;
1183 +    '?':
1184 +      Result := sqltPlaceholder;
1185 +    '|':
1186 +      Result := sqltPipe;
1187 +    '"':
1188 +      Result := sqltDoubleQuotes;
1189 +    '''':
1190 +      Result := sqltSingleQuotes;
1191 +    '/':
1192 +      Result := sqltForwardSlash;
1193 +    '\':
1194 +      Result := sqltBackslash;
1195 +    '*':
1196 +      Result := sqltAsterisk;
1197 +    '(':
1198 +      Result := sqltOpenBracket;
1199 +    ')':
1200 +      Result := sqltCloseBracket;
1201 +    ':':
1202 +      Result := sqltColon;
1203 +    ',':
1204 +      Result := sqltComma;
1205 +    '.':
1206 +      Result := sqltPeriod;
1207 +    '=':
1208 +      Result := sqltEquals;
1209 +    '[':
1210 +      Result := sqltOpenSquareBracket;
1211 +    ']':
1212 +      Result := sqltCloseSquareBracket;
1213 +    '<':
1214 +      Result := sqltLT;
1215 +    '>':
1216 +      Result := sqltGT;
1217 +    CR:
1218 +      Result := sqltCR;
1219 +    LF:
1220 +      Result := sqltEOL;
1221 +    else
1222 +      if C in ValidSQLIdentifierChars then
1223 +        Result := sqltIdentifier
1224 +      else
1225 +        Result := sqltOtherCharacter;
1226 +    end;
1227 +    FLastChar := C
1228 +  end;
1229 +  FNextToken := Result;
1230 + end;
1231 +
1232 + procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1233 + begin
1234 +  if FQFirst = FQLast then
1235 +    IBError(ibxeTokenQueueUnderflow,[]);
1236 +  token := FTokenQueue[FQFirst].token;
1237 +  FString := FTokenQueue[FQFirst].text;
1238 +  Inc(FQFirst);
1239 +  if FQFirst = FQLast then
1240 +    FQueueState := tsHold;
1241 + end;
1242 +
1243 + procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1244 + begin
1245 +  FString := source.FString;
1246 +  FNextToken := source.FNextToken;
1247 +  FTokenQueue := source.FTokenQueue;
1248 +  FQueueState := source.FQueueState;
1249 +  FQFirst := source.FQFirst;
1250 +  FQLast := source.FQLast;
1251 + end;
1252 +
1253 + function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1254 + begin
1255 +  Result := (FState = stDefault);
1256 +  if Result and (token = sqltIdentifier)  then
1257 +    FindReservedWord(FString,token);
1258 + end;
1259 +
1260 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1261 + begin
1262 +  if FQLast > TokenQueueMaxSize then
1263 +    IBError(ibxeTokenQueueOverflow,[]);
1264 +  FTokenQueue[FQLast].token := token;
1265 +  FTokenQueue[FQLast].text := text;
1266 +  Inc(FQLast);
1267 + end;
1268 +
1269 + procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1270 + begin
1271 +  QueueToken(token,TokenText);
1272 + end;
1273 +
1274 + procedure TSQLTokeniser.ResetQueue;
1275 + begin
1276 +  FQFirst := 0;
1277 +  FQLast := 0;
1278 +  FQueueState := tsHold;
1279 + end;
1280 +
1281 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1282 + begin
1283 +  ResetQueue;
1284 +  QueueToken(token,text);
1285 + end;
1286 +
1287 + procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1288 + begin
1289 +  ResetQueue;
1290 +  QueueToken(token);
1291 + end;
1292 +
1293 + procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1294 + begin
1295 +  FQueueState := tsRelease;
1296 +  PopQueue(token);
1297 + end;
1298 +
1299 + procedure TSQLTokeniser.ReleaseQueue;
1300 + begin
1301 +  FQueueState := tsRelease;
1302 + end;
1303 +
1304 + function TSQLTokeniser.GetQueuedText: AnsiString;
1305 + var i: integer;
1306 + begin
1307 +  Result := '';
1308 +  for i := FQFirst to FQLast do
1309 +    Result := Result + FTokenQueue[i].text;
1310 + end;
1311 +
1312 + procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1313 + begin
1314 +  FString := text;
1315 + end;
1316 +
1317 + constructor TSQLTokeniser.Create;
1318 + begin
1319 +  inherited Create;
1320 +  Reset;
1321 + end;
1322 +
1323 + destructor TSQLTokeniser.Destroy;
1324 + begin
1325 +  Reset;
1326 +  inherited Destroy;
1327 + end;
1328 +
1329 + procedure TSQLTokeniser.Reset;
1330 + begin
1331 +  FNextToken := sqltInit;
1332 +  FState := stDefault;
1333 +  FString := '';
1334 +  FEOF := false;
1335 +  ResetQueue;
1336 + end;
1337 +
1338 + function TSQLTokeniser.GetNextToken: TSQLTokens;
1339 + begin
1340 +  if FQueueState = tsRelease then
1341 +  repeat
1342 +    PopQueue(Result);
1343 +    FEOF := Result = sqltEOF;
1344 +    if TokenFound(Result) then
1345 +      Exit;
1346 +  until FQueueState <> tsRelease;
1347 +
1348 +  Result := InternalGetNextToken;
1349 + end;
1350 +
1351 + {a simple lookahead one algorithm to extra the next symbol}
1352 +
1353 + function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1354 + var C: AnsiChar;
1355 + begin
1356 +  Result := sqltEOF;
1357 +
1358 +  if FNextToken = sqltInit then
1359 +    GetNext;
1360 +
1361 +  repeat
1362 +    Result := FNextToken;
1363 +    C := FLastChar;
1364 +    GetNext;
1365 +
1366 +    if FSkipNext then
1367 +    begin
1368 +      FSkipNext := false;
1369 +      continue;
1370 +    end;
1371 +
1372 +    case FState of
1373 +    stInComment:
1374 +      begin
1375 +        if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1376 +        begin
1377 +          FState := stDefault;
1378 +          Result := sqltComment;
1379 +          GetNext;
1380 +        end
1381 +        else
1382 +          FString := FString + C;
1383 +      end;
1384 +
1385 +    stInCommentLine:
1386 +      begin
1387 +        case Result of
1388 +        sqltEOL:
1389 +          begin
1390 +            FState := stDefault;
1391 +            Result := sqltCommentLine;
1392 +          end;
1393 +
1394 +        sqltCR: {ignore};
1395 +
1396 +        else
1397 +          FString := FString + C;
1398 +        end;
1399 +      end;
1400 +
1401 +    stSingleQuoted:
1402 +      begin
1403 +        if (Result = sqltSingleQuotes) then
1404 +        begin
1405 +          if (FNextToken = sqltSingleQuotes) then
1406 +          begin
1407 +            FSkipNext := true;
1408 +            FString := FString + C;
1409 +          end
1410 +          else
1411 +          begin
1412 +            Result := sqltQuotedString;
1413 +            FState := stDefault;
1414 +          end;
1415 +        end
1416 +        else
1417 +          FString := FString + C;
1418 +      end;
1419 +
1420 +    stDoubleQuoted:
1421 +      begin
1422 +        if (Result = sqltDoubleQuotes) then
1423 +        begin
1424 +          if (FNextToken = sqltDoubleQuotes) then
1425 +          begin
1426 +            FSkipNext := true;
1427 +            FString := FString + C;
1428 +          end
1429 +          else
1430 +          begin
1431 +            Result := sqltIdentifierInDoubleQuotes;
1432 +            FState := stDefault;
1433 +          end;
1434 +        end
1435 +        else
1436 +          FString := FString + C;
1437 +      end;
1438 +
1439 +    stInIdentifier:
1440 +      begin
1441 +        FString := FString + C;
1442 +        Result := sqltIdentifier;
1443 +        if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1444 +          FState := stDefault
1445 +      end;
1446 +
1447 +    stInNumeric:
1448 +      begin
1449 +        FString := FString + C;
1450 +        if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1451 +        begin
1452 +          {malformed decimal}
1453 +          FState := stInIdentifier;
1454 +          Result := sqltIdentifier
1455 +        end
1456 +        else
1457 +        begin
1458 +          if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1459 +            FState := stDefault;
1460 +          Result := sqltNumberString;
1461 +        end;
1462 +      end;
1463 +
1464 +    else {stDefault}
1465 +      begin
1466 +        FString := C;
1467 +        case Result of
1468 +
1469 +        sqltPipe:
1470 +          if FNextToken = sqltPipe then
1471 +          begin
1472 +            Result := sqltConcatSymbol;
1473 +            FString := C + FLastChar;
1474 +            GetNext;
1475 +          end;
1476 +
1477 +        sqltForwardSlash:
1478 +          begin
1479 +            if FNextToken = sqltAsterisk then
1480 +            begin
1481 +              FString := '';
1482 +              GetNext;
1483 +              FState := stInComment;
1484 +            end
1485 +            else
1486 +            if FNextToken = sqltForwardSlash then
1487 +            begin
1488 +              FString := '';
1489 +              GetNext;
1490 +              FState := stInCommentLine;
1491 +            end;
1492 +          end;
1493 +
1494 +        sqltSingleQuotes:
1495 +          begin
1496 +            FString := '';
1497 +            FState := stSingleQuoted;
1498 +          end;
1499 +
1500 +        sqltDoubleQuotes:
1501 +          begin
1502 +            FString := '';
1503 +            FState := stDoubleQuoted;
1504 +          end;
1505 +
1506 +        sqltIdentifier:
1507 +          if FNextToken in [sqltIdentifier,sqltNumberString] then
1508 +            FState := stInIdentifier;
1509 +
1510 +        sqltNumberString:
1511 +          if FNextToken in [sqltNumberString,sqltPeriod] then
1512 +            FState := stInNumeric;
1513 +        end;
1514 +      end;
1515 +    end;
1516 +
1517 + //    writeln(FString);
1518 +    FEOF := Result = sqltEOF;
1519 +  until TokenFound(Result) or EOF;
1520 + end;
1521 +
1522   end.

Diff Legend

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