journaling/fbintf/IBUtils.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{                                                                        }
{************************************************************************}

unit IBUtils;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS}
{$ENDIF}

{$IFDEF FPC}
{$Mode Delphi}
{$codepage UTF8}
{$define HASREQEX}
{$ENDIF}


interface

uses Classes, SysUtils, IB;

const
  CRLF = #13 + #10;
  CR   = #13;
  LF   = #10;
  TAB  = #9;
  NULL_TERMINATOR = #0;

  sqlReservedWords: array [0..198] of string = (
  'ADD',
  'ADMIN',
  'ALL',
  'ALTER',
  'AND',
  'ANY',
  'AS',
  'AT',
  'AVG',
  'BEGIN',
  'BETWEEN',
  'BIGINT',
  'BIT_LENGTH',
  'BLOB',
  'BOOLEAN',
  'BOTH',
  'BY',
  'CASE',
  'CAST',
  'CHAR',
  'CHAR_LENGTH',
  'CHARACTER',
  'CHARACTER_LENGTH',
  'CHECK',
  'CLOSE',
  'COLLATE',
  'COLUMN',
  'COMMIT',
  'CONNECT',
  'CONSTRAINT',
  'CORR',
  'COUNT',
  'COVAR_POP',
  'COVAR_SAMP',
  'CREATE',
  'CROSS',
  'CURRENT',
  'CURRENT_CONNECTION',
  'CURRENT_DATE',
  'CURRENT_ROLE',
  'CURRENT_TIME',
  'CURRENT_TIMESTAMP',
  'CURRENT_TRANSACTION',
  'CURRENT_USER',
  'CURSOR',
  'DATE',
  'DAY',
  'DEC',
  'DECIMAL',
  'DECLARE',
  'DEFAULT',
  'DELETE',
  'DELETING',
  'DETERMINISTIC',
  'DISCONNECT',
  'DISTINCT',
  'DOUBLE',
  'DROP',
  'ELSE',
  'END',
  'ESCAPE',
  'EXECUTE',
  'EXISTS',
  'EXTERNAL',
  'EXTRACT',
  'FALSE',
  'FETCH',
  'FILTER',
  'FLOAT',
  'FOR',
  'FOREIGN',
  'FROM',
  'FULL',
  'FUNCTION',
  'GDSCODE',
  'GLOBAL',
  'GRANT',
  'GROUP',
  'HAVING',
  'HOUR',
  'IN',
  'INDEX',
  'INNER',
  'INSENSITIVE',
  'INSERT',
  'INSERTING',
  'INT',
  'INTEGER',
  'INTO',
  'IS',
  'JOIN',
  'KEY',
  'LEADING',
  'LEFT',
  'LIKE',
  'LONG',
  'LOWER',
  'MAX',
  'MAXIMUM_SEGMENT',
  'MERGE',
  'MIN',
  'MINUTE',
  'MONTH',
  'NATIONAL',
  'NATURAL',
  'NCHAR',
  'NO',
  'NOT',
  'NULL',
  'NUMERIC',
  'OCTET_LENGTH',
  'OF',
  'OFFSET',
  'ON',
  'ONLY',
  'OPEN',
  'OR',
  'ORDER',
  'OUTER',
  'OVER',
  'PARAMETER',
  'PLAN',
  'POSITION',
  'POST_EVENT',
  'PRECISION',
  'PRIMARY',
  'PROCEDURE',
  'RDB$DB_KEY',
  'RDB$RECORD_VERSION',
  'REAL',
  'RECORD_VERSION',
  'RECREATE',
  'RECURSIVE',
  'REFERENCES',
  'REGR_AVGX',
  'REGR_AVGY',
  'REGR_COUNT',
  'REGR_INTERCEPT',
  'REGR_R2',
  'REGR_SLOPE',
  'REGR_SXX',
  'REGR_SXY',
  'REGR_SYY',
  'RELEASE',
  'RETURN',
  'RETURNING_VALUES',
  'RETURNS',
  'REVOKE',
  'RIGHT',
  'ROLLBACK',
  'ROW',
  'ROW_COUNT',
  'ROWS',
  'SAVEPOINT',
  'SCROLL',
  'SECOND',
  'SELECT',
  'SENSITIVE',
  'SET',
  'SIMILAR',
  'SMALLINT',
  'SOME',
  'SQLCODE',
  'SQLSTATE',
  'SQLSTATE',
  'START',
  'STDDEV_POP',
  'STDDEV_SAMP',
  'SUM',
  'TABLE',
  'THEN',
  'TIME',
  'TIMESTAMP',
  'TO',
  'TRAILING',
  'TRIGGER',
  'TRIM',
  'TRUE',
  'UNION',
  'UNIQUE',
  'UNKNOWN',
  'UPDATE',
  'UPDATING',
  'UPPER',
  'USER',
  'USING',
  'VALUE',
  'VALUES',
  'VAR_POP',
  'VAR_SAMP',
  'VARCHAR',
  'VARIABLE',
  'VARYING',
  'VIEW',
  'WHEN',
  'WHERE',
  'WHILE',
  'WITH',
  'YEAR'
  );

function Max(n1, n2: Integer): Integer;
function Min(n1, n2: Integer): Integer;
function RandomString(iLength: Integer): AnsiString;
function RandomInteger(iLow, iHigh: Integer): Integer;
function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
function Space2Underscore(s: AnsiString): AnsiString;
function SQLSafeString(const s: AnsiString): AnsiString;
function IsSQLIdentifier(Value: AnsiString): boolean;
function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
              PortNo: AnsiString = ''): AnsiString;
function ParseConnectString(ConnectString: AnsiString;
              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
              var PortNo: AnsiString): boolean;
function GetProtocol(ConnectString: AnsiString): TProtocolAll;

implementation

{$IFDEF HASREQEX}
uses RegExpr;
{$ENDIF}

function Max(n1, n2: Integer): Integer;
begin
  if (n1 > n2) then
    result := n1
  else
    result := n2;
end;

function Min(n1, n2: Integer): Integer;
begin
  if (n1 < n2) then
    result := n1
  else
    result := n2;
end;

function RandomString(iLength: Integer): AnsiString;
begin
  result := '';
  while Length(result) < iLength do
    result := result + IntToStr(RandomInteger(0, High(Integer)));
  if Length(result) > iLength then
    result := Copy(result, 1, iLength);
end;

function RandomInteger(iLow, iHigh: Integer): Integer;
begin
  result := Trunc(Random(iHigh - iLow)) + iLow;
end;

function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
var
  i: Integer;
begin
  result := '';
  for i := 1 to Length(st) do begin
    if AnsiPos(st[i], CharsToStrip) = 0 then
      result := result + st[i];
  end;
end;

{Extracts SQL Identifier typically from a  Dialect 3 encoding}

function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
begin
  Value := Trim(Value);
  if Dialect = 1 then
    Value := AnsiUpperCase(Value)  
  else
  begin
    if (Value <> '') and (Value[1] = '"') then
    begin
      Delete(Value, 1, 1);
      Delete(Value, Length(Value), 1);
      Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
    end
    else
      Value := AnsiUpperCase(Value);
  end;
  Result := Value;
end;

{Returns true if "w" is a Firebird SQL reserved word}

function IsReservedWord(w: AnsiString): boolean;
var i: integer;
begin
     Result := true;
     for i := 0 to Length(sqlReservedWords) - 1 do
         if w = sqlReservedWords[i] then
            Exit;
     Result := false;
end;

{Format an SQL Identifier according to SQL Dialect}

function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
begin
  if Dialect = 1 then
    Value := AnsiUpperCase(Trim(Value))
  else
    Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
  Result := Value;
end;

const
  ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];

{Returns true if the value is a valid SQL Identifier - note lower case accepted}

function IsSQLIdentifier(Value: AnsiString): boolean;
var i: integer;
begin
  Result := false;
  for i := 1 to Length(Value) do
    if not (Value[i] in ValidSQLIdentifierChars) then Exit;
  Result := true;
end;

{Extracts the Database Connect string from a Create Database Statement}

{$IFDEF HASREQEX}
function ExtractConnectString(const CreateSQL: AnsiString;
  var ConnectString: AnsiString): boolean;
var RegexObj: TRegExpr;
begin
  RegexObj := TRegExpr.Create;
  try
    {extact database file spec}
    RegexObj.ModifierG := false; {turn off greedy matches}
    RegexObj.ModifierI := true; {case insensitive match}
    RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
    Result := RegexObj.Exec(CreateSQL);
    if Result then
      ConnectString := RegexObj.Match[2];
  finally
    RegexObj.Free;
  end;
end;

function ParseConnectString(ConnectString: AnsiString; var ServerName,
  DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
  ): boolean;

  function GetProtocol(scheme: AnsiString): TProtocolAll;
  begin
    scheme := AnsiUpperCase(scheme);
    if scheme = 'INET' then
      Result := inet
    else
    if scheme = 'INET4' then
      Result := inet4
    else
    if scheme = 'INET6' then
      Result := inet6
    else
    if scheme = 'XNET' then
      Result := xnet
    else
    if scheme = 'WNET' then
      Result := wnet
  end;

var RegexObj: TRegExpr;
begin
  ServerName := '';
  DatabaseName := ConnectString;
  PortNo := '';
  Protocol := unknownProtocol;
  RegexObj := TRegExpr.Create;
  try
    {extact database file spec}
    RegexObj.ModifierG := false; {turn off greedy matches}
    RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
    Result := RegexObj.Exec(ConnectString);
    if Result then
    begin
      {URL type connect string}
      Protocol := GetProtocol(RegexObj.Match[1]);
      ServerName := RegexObj.Match[2];
      if RegexObj.MatchLen[3] > 0 then
        PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
      DatabaseName := RegexObj.Match[4];
      if ServerName = '' then
        DatabaseName := '/' + DatabaseName;
    end
    else
    begin
      {URL type connect string - local loop}
      RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
      Result := RegexObj.Exec(ConnectString);
      if Result then
      begin
        Protocol := GetProtocol(RegexObj.Match[1]);
        DatabaseName := RegexObj.Match[2];
      end
      else
      begin
        RegexObj.Expression := '^([a-zA-Z]:\\.*)';
        Result := RegexObj.Exec(ConnectString);
        if Result then
          Protocol := Local {Windows with leading drive ID}
        else
        begin
          RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
          Result := RegexObj.Exec(ConnectString);
          if Result then
          begin
            {Legacy TCP Format}
            ServerName := RegexObj.Match[1];
            if RegexObj.MatchLen[2] > 0 then
              PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
            DatabaseName := RegexObj.Match[3];
            Protocol := TCP;
          end
          else
          begin
            RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
            Result := RegexObj.Exec(ConnectString);
            if Result then
            begin
              {Netbui}
              ServerName := RegexObj.Match[1];
              if RegexObj.MatchLen[2] > 0 then
                PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
              DatabaseName := RegexObj.Match[3];
              Protocol := NamedPipe
            end
            else
            begin
              Result := true;
              Protocol := Local; {Assume local}
            end;
          end;
        end;
      end;
    end;
  finally
    RegexObj.Free;
  end;
end;

function GetProtocol(ConnectString: AnsiString): TProtocolAll;
var ServerName,
    DatabaseName: AnsiString;
    PortNo: AnsiString;
begin
  ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
end;

{$ELSE}
{cruder version of above for Delphi. Older versions lack regular expression
 handling.}
function ExtractConnectString(const CreateSQL: AnsiString;
  var ConnectString: AnsiString): boolean;
var i: integer;
begin
  Result := false;
  i := Pos('''',CreateSQL);
  if i > 0 then
  begin
    ConnectString := CreateSQL;
    delete(ConnectString,1,i);
    i := Pos('''',ConnectString);
    if i > 0 then
    begin
      delete(ConnectString,i,Length(ConnectString)-i+1);
      Result := true;
    end;
  end;
end;

function GetProtocol(ConnectString: AnsiString): TProtocolAll;
begin
  Result := unknownProtocol; {not implemented for Delphi}
end;

function ParseConnectString(ConnectString: AnsiString;
              var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
              var PortNo: AnsiString): boolean;
begin
  Result := false;
end;

{$ENDIF}

{Make a connect string in format appropriate protocol}

function MakeConnectString(ServerName, DatabaseName: AnsiString;
  Protocol: TProtocol; PortNo: AnsiString): AnsiString;

  function FormatURL: AnsiString;
  begin
    if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
      Result := DatabaseName
    else
      Result := ServerName + '/' + DatabaseName;
  end;

begin
  if PortNo <> '' then
    case Protocol of
    NamedPipe:
      ServerName := ServerName + '@' + PortNo;
    Local,
    SPX,
    xnet: {do nothing};
    TCP:
      ServerName := ServerName + '/' + PortNo;
    else
      ServerName := ServerName + ':' + PortNo;
    end;

  case Protocol of
    TCP:        Result := ServerName + ':' + DatabaseName; {do not localize}
    SPX:        Result := ServerName + '@' + DatabaseName; {do not localize}
    NamedPipe:  Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
    Local:      Result := DatabaseName; {do not localize}
    inet:       Result := 'inet://' + FormatURL; {do not localize}
    inet4:       Result := 'inet4://' + FormatURL; {do not localize}
    inet6:       Result := 'inet6://' + FormatURL; {do not localize}
    wnet:       Result := 'wnet://' + FormatURL; {do not localize}
    xnet:       Result := 'xnet://' + FormatURL;  {do not localize}
  end;
end;

{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}

function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
begin
  if (Dialect = 3) and
    (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
     Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
  else
    Result := Value
end;

{Replaces unknown characters in a string with underscores}

function Space2Underscore(s: AnsiString): AnsiString;
var
   k: integer;
begin
     Result := s;
     for k := 1 to Length(s) do
         if not (Result[k] in ValidSQLIdentifierChars)  then
            Result[k] := '_';
end;

{Reformats an SQL string with single quotes duplicated.}

function SQLSafeString(const s: AnsiString): AnsiString;
begin
  Result := StringReplace(s,'''','''''',[rfReplaceAll]);
end;

end.
Revision:	231
Committed:	Mon Apr 16 08:32:21 2018 UTC (6 years ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/fbintf/IBUtils.pas*
File size:	15796 byte(s)
Log Message:	Fixes merged
#	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	tony	118	{$define HASREQEX}
43	tony	45	{$ENDIF}
44
45	tony	118
46	tony	45	interface
47
48	tony	143	uses Classes, SysUtils, IB;
49	tony	45
50			const
51			CRLF = #13 + #10;
52			CR = #13;
53			LF = #10;
54			TAB = #9;
55			NULL_TERMINATOR = #0;
56
57	tony	209	sqlReservedWords: array [0..198] of string = (
58	tony	47	'ADD',
59			'ADMIN',
60			'ALL',
61			'ALTER',
62			'AND',
63			'ANY',
64			'AS',
65			'AT',
66			'AVG',
67			'BEGIN',
68			'BETWEEN',
69			'BIGINT',
70			'BIT_LENGTH',
71			'BLOB',
72			'BOOLEAN',
73			'BOTH',
74			'BY',
75			'CASE',
76			'CAST',
77			'CHAR',
78			'CHAR_LENGTH',
79			'CHARACTER',
80			'CHARACTER_LENGTH',
81			'CHECK',
82			'CLOSE',
83			'COLLATE',
84			'COLUMN',
85			'COMMIT',
86			'CONNECT',
87			'CONSTRAINT',
88			'CORR',
89			'COUNT',
90			'COVAR_POP',
91			'COVAR_SAMP',
92			'CREATE',
93			'CROSS',
94			'CURRENT',
95			'CURRENT_CONNECTION',
96			'CURRENT_DATE',
97			'CURRENT_ROLE',
98			'CURRENT_TIME',
99			'CURRENT_TIMESTAMP',
100			'CURRENT_TRANSACTION',
101			'CURRENT_USER',
102			'CURSOR',
103			'DATE',
104			'DAY',
105			'DEC',
106			'DECIMAL',
107			'DECLARE',
108			'DEFAULT',
109			'DELETE',
110			'DELETING',
111			'DETERMINISTIC',
112			'DISCONNECT',
113			'DISTINCT',
114			'DOUBLE',
115			'DROP',
116			'ELSE',
117			'END',
118			'ESCAPE',
119			'EXECUTE',
120			'EXISTS',
121			'EXTERNAL',
122			'EXTRACT',
123			'FALSE',
124			'FETCH',
125			'FILTER',
126			'FLOAT',
127			'FOR',
128			'FOREIGN',
129			'FROM',
130			'FULL',
131			'FUNCTION',
132			'GDSCODE',
133			'GLOBAL',
134			'GRANT',
135			'GROUP',
136			'HAVING',
137			'HOUR',
138			'IN',
139			'INDEX',
140			'INNER',
141			'INSENSITIVE',
142			'INSERT',
143			'INSERTING',
144			'INT',
145			'INTEGER',
146			'INTO',
147			'IS',
148			'JOIN',
149	tony	209	'KEY',
150	tony	47	'LEADING',
151			'LEFT',
152			'LIKE',
153			'LONG',
154			'LOWER',
155			'MAX',
156			'MAXIMUM_SEGMENT',
157			'MERGE',
158			'MIN',
159			'MINUTE',
160			'MONTH',
161			'NATIONAL',
162			'NATURAL',
163			'NCHAR',
164			'NO',
165			'NOT',
166			'NULL',
167			'NUMERIC',
168			'OCTET_LENGTH',
169			'OF',
170			'OFFSET',
171			'ON',
172			'ONLY',
173			'OPEN',
174			'OR',
175			'ORDER',
176			'OUTER',
177			'OVER',
178			'PARAMETER',
179			'PLAN',
180			'POSITION',
181			'POST_EVENT',
182			'PRECISION',
183			'PRIMARY',
184			'PROCEDURE',
185			'RDB$DB_KEY',
186			'RDB$RECORD_VERSION',
187			'REAL',
188			'RECORD_VERSION',
189			'RECREATE',
190			'RECURSIVE',
191			'REFERENCES',
192			'REGR_AVGX',
193			'REGR_AVGY',
194			'REGR_COUNT',
195			'REGR_INTERCEPT',
196			'REGR_R2',
197			'REGR_SLOPE',
198			'REGR_SXX',
199			'REGR_SXY',
200			'REGR_SYY',
201			'RELEASE',
202			'RETURN',
203			'RETURNING_VALUES',
204			'RETURNS',
205			'REVOKE',
206			'RIGHT',
207			'ROLLBACK',
208			'ROW',
209			'ROW_COUNT',
210			'ROWS',
211			'SAVEPOINT',
212			'SCROLL',
213			'SECOND',
214			'SELECT',
215			'SENSITIVE',
216			'SET',
217			'SIMILAR',
218			'SMALLINT',
219			'SOME',
220			'SQLCODE',
221			'SQLSTATE',
222			'SQLSTATE',
223			'START',
224			'STDDEV_POP',
225			'STDDEV_SAMP',
226			'SUM',
227			'TABLE',
228			'THEN',
229			'TIME',
230			'TIMESTAMP',
231			'TO',
232			'TRAILING',
233			'TRIGGER',
234			'TRIM',
235			'TRUE',
236			'UNION',
237			'UNIQUE',
238			'UNKNOWN',
239			'UPDATE',
240			'UPDATING',
241			'UPPER',
242			'USER',
243			'USING',
244			'VALUE',
245			'VALUES',
246			'VAR_POP',
247			'VAR_SAMP',
248			'VARCHAR',
249			'VARIABLE',
250			'VARYING',
251			'VIEW',
252			'WHEN',
253			'WHERE',
254			'WHILE',
255			'WITH',
256			'YEAR'
257			);
258	tony	45
259			function Max(n1, n2: Integer): Integer;
260			function Min(n1, n2: Integer): Integer;
261	tony	56	function RandomString(iLength: Integer): AnsiString;
262	tony	45	function RandomInteger(iLow, iHigh: Integer): Integer;
263	tony	56	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
264			function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
265			function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
266			function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
267			function Space2Underscore(s: AnsiString): AnsiString;
268			function SQLSafeString(const s: AnsiString): AnsiString;
269	tony	107	function IsSQLIdentifier(Value: AnsiString): boolean;
270	tony	117	function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
271	tony	143	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
272			PortNo: AnsiString = ''): AnsiString;
273			function ParseConnectString(ConnectString: AnsiString;
274			var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
275			var PortNo: AnsiString): boolean;
276			function GetProtocol(ConnectString: AnsiString): TProtocolAll;
277	tony	45
278			implementation
279
280	tony	118	{$IFDEF HASREQEX}
281	tony	117	uses RegExpr;
282	tony	118	{$ENDIF}
283	tony	117
284	tony	45	function Max(n1, n2: Integer): Integer;
285			begin
286			if (n1 > n2) then
287			result := n1
288			else
289			result := n2;
290			end;
291
292			function Min(n1, n2: Integer): Integer;
293			begin
294			if (n1 < n2) then
295			result := n1
296			else
297			result := n2;
298			end;
299
300	tony	56	function RandomString(iLength: Integer): AnsiString;
301	tony	45	begin
302			result := '';
303			while Length(result) < iLength do
304			result := result + IntToStr(RandomInteger(0, High(Integer)));
305			if Length(result) > iLength then
306			result := Copy(result, 1, iLength);
307			end;
308
309			function RandomInteger(iLow, iHigh: Integer): Integer;
310			begin
311			result := Trunc(Random(iHigh - iLow)) + iLow;
312			end;
313
314	tony	56	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
315	tony	45	var
316			i: Integer;
317			begin
318			result := '';
319			for i := 1 to Length(st) do begin
320			if AnsiPos(st[i], CharsToStrip) = 0 then
321			result := result + st[i];
322			end;
323			end;
324
325	tony	117	{Extracts SQL Identifier typically from a Dialect 3 encoding}
326	tony	45
327	tony	117	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
328	tony	45	begin
329			Value := Trim(Value);
330			if Dialect = 1 then
331			Value := AnsiUpperCase(Value)
332			else
333			begin
334			if (Value <> '') and (Value[1] = '"') then
335			begin
336			Delete(Value, 1, 1);
337			Delete(Value, Length(Value), 1);
338			Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
339			end
340			else
341			Value := AnsiUpperCase(Value);
342			end;
343			Result := Value;
344			end;
345
346	tony	117	{Returns true if "w" is a Firebird SQL reserved word}
347	tony	45
348	tony	56	function IsReservedWord(w: AnsiString): boolean;
349	tony	45	var i: integer;
350			begin
351			Result := true;
352			for i := 0 to Length(sqlReservedWords) - 1 do
353			if w = sqlReservedWords[i] then
354			Exit;
355			Result := false;
356			end;
357
358	tony	117	{Format an SQL Identifier according to SQL Dialect}
359
360	tony	56	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
361	tony	45	begin
362			if Dialect = 1 then
363			Value := AnsiUpperCase(Trim(Value))
364			else
365	tony	117	Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
366	tony	45	Result := Value;
367			end;
368
369	tony	107	const
370			ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
371
372	tony	117	{Returns true if the value is a valid SQL Identifier - note lower case accepted}
373
374	tony	107	function IsSQLIdentifier(Value: AnsiString): boolean;
375			var i: integer;
376			begin
377			Result := false;
378			for i := 1 to Length(Value) do
379			if not (Value[i] in ValidSQLIdentifierChars) then Exit;
380			Result := true;
381			end;
382
383	tony	117	{Extracts the Database Connect string from a Create Database Statement}
384
385	tony	118	{$IFDEF HASREQEX}
386	tony	117	function ExtractConnectString(const CreateSQL: AnsiString;
387			var ConnectString: AnsiString): boolean;
388			var RegexObj: TRegExpr;
389			begin
390			RegexObj := TRegExpr.Create;
391			try
392			{extact database file spec}
393			RegexObj.ModifierG := false; {turn off greedy matches}
394			RegexObj.ModifierI := true; {case insensitive match}
395			RegexObj.Expression := '^ CREATE +(DATABASE\|SCHEMA) +''(.)''';
396			Result := RegexObj.Exec(CreateSQL);
397			if Result then
398	tony	143	ConnectString := RegexObj.Match[2];
399	tony	117	finally
400			RegexObj.Free;
401			end;
402			end;
403	tony	143
404			function ParseConnectString(ConnectString: AnsiString; var ServerName,
405			DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
406			): boolean;
407	tony	231
408			function GetProtocol(scheme: AnsiString): TProtocolAll;
409			begin
410			scheme := AnsiUpperCase(scheme);
411			if scheme = 'INET' then
412			Result := inet
413			else
414			if scheme = 'INET4' then
415			Result := inet4
416			else
417			if scheme = 'INET6' then
418			Result := inet6
419			else
420			if scheme = 'XNET' then
421			Result := xnet
422			else
423			if scheme = 'WNET' then
424			Result := wnet
425			end;
426
427	tony	143	var RegexObj: TRegExpr;
428			begin
429			ServerName := '';
430			DatabaseName := ConnectString;
431			PortNo := '';
432			Protocol := unknownProtocol;
433			RegexObj := TRegExpr.Create;
434			try
435			{extact database file spec}
436			RegexObj.ModifierG := false; {turn off greedy matches}
437	tony	231	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.])(\|:[0-9a-zA-Z\-]+)/(.)$';
438	tony	143	Result := RegexObj.Exec(ConnectString);
439			if Result then
440			begin
441			{URL type connect string}
442	tony	231	Protocol := GetProtocol(RegexObj.Match[1]);
443	tony	143	ServerName := RegexObj.Match[2];
444			if RegexObj.MatchLen[3] > 0 then
445			PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
446			DatabaseName := RegexObj.Match[4];
447	tony	231	if ServerName = '' then
448			DatabaseName := '/' + DatabaseName;
449	tony	143	end
450			else
451			begin
452	tony	231	{URL type connect string - local loop}
453			RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
454	tony	143	Result := RegexObj.Exec(ConnectString);
455			if Result then
456	tony	231	begin
457			Protocol := GetProtocol(RegexObj.Match[1]);
458			DatabaseName := RegexObj.Match[2];
459			end
460	tony	143	else
461			begin
462	tony	231	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
463	tony	143	Result := RegexObj.Exec(ConnectString);
464			if Result then
465	tony	231	Protocol := Local {Windows with leading drive ID}
466	tony	143	else
467			begin
468	tony	231	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(\|/[0-9a-zA-Z\-]+):(.*)$';
469	tony	143	Result := RegexObj.Exec(ConnectString);
470			if Result then
471			begin
472	tony	231	{Legacy TCP Format}
473	tony	143	ServerName := RegexObj.Match[1];
474			if RegexObj.MatchLen[2] > 0 then
475			PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
476			DatabaseName := RegexObj.Match[3];
477	tony	231	Protocol := TCP;
478	tony	143	end
479			else
480			begin
481	tony	231	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(\|@[0-9a-zA-Z\-]+)\\(.*)$';
482			Result := RegexObj.Exec(ConnectString);
483			if Result then
484			begin
485			{Netbui}
486			ServerName := RegexObj.Match[1];
487			if RegexObj.MatchLen[2] > 0 then
488			PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
489			DatabaseName := RegexObj.Match[3];
490			Protocol := NamedPipe
491			end
492			else
493			begin
494			Result := true;
495			Protocol := Local; {Assume local}
496			end;
497	tony	143	end;
498			end;
499			end;
500			end;
501			finally
502			RegexObj.Free;
503			end;
504			end;
505
506			function GetProtocol(ConnectString: AnsiString): TProtocolAll;
507			var ServerName,
508			DatabaseName: AnsiString;
509			PortNo: AnsiString;
510			begin
511			ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
512			end;
513
514	tony	118	{$ELSE}
515	tony	121	{cruder version of above for Delphi. Older versions lack regular expression
516			handling.}
517	tony	118	function ExtractConnectString(const CreateSQL: AnsiString;
518			var ConnectString: AnsiString): boolean;
519			var i: integer;
520			begin
521			Result := false;
522			i := Pos('''',CreateSQL);
523			if i > 0 then
524			begin
525			ConnectString := CreateSQL;
526			delete(ConnectString,1,i);
527			i := Pos('''',ConnectString);
528			if i > 0 then
529			begin
530			delete(ConnectString,i,Length(ConnectString)-i+1);
531			Result := true;
532			end;
533			end;
534			end;
535	tony	143
536			function GetProtocol(ConnectString: AnsiString): TProtocolAll;
537			begin
538			Result := unknownProtocol; {not implemented for Delphi}
539			end;
540
541			function ParseConnectString(ConnectString: AnsiString;
542			var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
543			var PortNo: AnsiString): boolean;
544			begin
545			Result := false;
546			end;
547
548	tony	118	{$ENDIF}
549	tony	117
550	tony	143	{Make a connect string in format appropriate protocol}
551
552			function MakeConnectString(ServerName, DatabaseName: AnsiString;
553			Protocol: TProtocol; PortNo: AnsiString): AnsiString;
554	tony	231
555			function FormatURL: AnsiString;
556			begin
557			if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
558			Result := DatabaseName
559			else
560			Result := ServerName + '/' + DatabaseName;
561			end;
562
563	tony	143	begin
564			if PortNo <> '' then
565			case Protocol of
566			NamedPipe:
567			ServerName := ServerName + '@' + PortNo;
568			Local,
569			SPX,
570			xnet: {do nothing};
571			TCP:
572			ServerName := ServerName + '/' + PortNo;
573			else
574			ServerName := ServerName + ':' + PortNo;
575			end;
576
577			case Protocol of
578			TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
579			SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
580			NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
581			Local: Result := DatabaseName; {do not localize}
582	tony	231	inet: Result := 'inet://' + FormatURL; {do not localize}
583			inet4: Result := 'inet4://' + FormatURL; {do not localize}
584			inet6: Result := 'inet6://' + FormatURL; {do not localize}
585			wnet: Result := 'wnet://' + FormatURL; {do not localize}
586			xnet: Result := 'xnet://' + FormatURL; {do not localize}
587	tony	143	end;
588			end;
589
590	tony	117	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
591
592	tony	56	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
593	tony	45	begin
594			if (Dialect = 3) and
595	tony	115	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
596	tony	117	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
597	tony	45	else
598			Result := Value
599			end;
600
601	tony	117	{Replaces unknown characters in a string with underscores}
602
603	tony	56	function Space2Underscore(s: AnsiString): AnsiString;
604	tony	45	var
605			k: integer;
606			begin
607			Result := s;
608			for k := 1 to Length(s) do
609	tony	117	if not (Result[k] in ValidSQLIdentifierChars) then
610	tony	45	Result[k] := '_';
611			end;
612
613	tony	117	{Reformats an SQL string with single quotes duplicated.}
614
615	tony	56	function SQLSafeString(const s: AnsiString): AnsiString;
616	tony	47	begin
617			Result := StringReplace(s,'''','''''',[rfReplaceAll]);
618			end;
619	tony	45
620			end.