trunk/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, 7 months ago) by tony
Content type:	text/x-pascal
File size:	15796 byte(s)
Log Message:	Fixes merged
#	Content
1	{************************************************************************}
2	{ }
3	{ Borland Delphi Visual Component Library }
4	{ InterBase Express core components }
5	{ }
6	{ Copyright (c) 1998-2000 Inprise Corporation }
7	{ }
8	{ InterBase Express is based in part on the product }
9	{ Free IB Components, written by Gregory H. Deatz for }
10	{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11	{ Free IB Components is used under license. }
12	{ }
13	{ The contents of this file are subject to the InterBase }
14	{ Public License Version 1.0 (the "License"); you may not }
15	{ use this file except in compliance with the License. You }
16	{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	{ Software distributed under the License is distributed on }
18	{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19	{ express or implied. See the License for the specific language }
20	{ governing rights and limitations under the License. }
21	{ The Original Code was created by InterBase Software Corporation }
22	{ and its successors. }
23	{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24	{ Corporation. All Rights Reserved. }
25	{ Contributor(s): Jeff Overcash }
26	{ }
27	{ IBX For Lazarus (Firebird Express) }
28	{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29	{ Portions created by MWA Software are copyright McCallum Whyman }
30	{ Associates Ltd 2011 }
31	{ }
32	{************************************************************************}
33
34	unit IBUtils;
35	{$IFDEF MSWINDOWS}
36	{$DEFINE WINDOWS}
37	{$ENDIF}
38
39	{$IFDEF FPC}
40	{$Mode Delphi}
41	{$codepage UTF8}
42	{$define HASREQEX}
43	{$ENDIF}
44
45
46	interface
47
48	uses Classes, SysUtils, IB;
49
50	const
51	CRLF = #13 + #10;
52	CR = #13;
53	LF = #10;
54	TAB = #9;
55	NULL_TERMINATOR = #0;
56
57	sqlReservedWords: array [0..198] of string = (
58	'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	'KEY',
150	'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
259	function Max(n1, n2: Integer): Integer;
260	function Min(n1, n2: Integer): Integer;
261	function RandomString(iLength: Integer): AnsiString;
262	function RandomInteger(iLow, iHigh: Integer): Integer;
263	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	function IsSQLIdentifier(Value: AnsiString): boolean;
270	function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
271	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
278	implementation
279
280	{$IFDEF HASREQEX}
281	uses RegExpr;
282	{$ENDIF}
283
284	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	function RandomString(iLength: Integer): AnsiString;
301	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	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
315	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	{Extracts SQL Identifier typically from a Dialect 3 encoding}
326
327	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
328	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	{Returns true if "w" is a Firebird SQL reserved word}
347
348	function IsReservedWord(w: AnsiString): boolean;
349	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	{Format an SQL Identifier according to SQL Dialect}
359
360	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
361	begin
362	if Dialect = 1 then
363	Value := AnsiUpperCase(Trim(Value))
364	else
365	Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
366	Result := Value;
367	end;
368
369	const
370	ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
371
372	{Returns true if the value is a valid SQL Identifier - note lower case accepted}
373
374	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	{Extracts the Database Connect string from a Create Database Statement}
384
385	{$IFDEF HASREQEX}
386	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	ConnectString := RegexObj.Match[2];
399	finally
400	RegexObj.Free;
401	end;
402	end;
403
404	function ParseConnectString(ConnectString: AnsiString; var ServerName,
405	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
406	): boolean;
407
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	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	RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.])(\|:[0-9a-zA-Z\-]+)/(.)$';
438	Result := RegexObj.Exec(ConnectString);
439	if Result then
440	begin
441	{URL type connect string}
442	Protocol := GetProtocol(RegexObj.Match[1]);
443	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	if ServerName = '' then
448	DatabaseName := '/' + DatabaseName;
449	end
450	else
451	begin
452	{URL type connect string - local loop}
453	RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
454	Result := RegexObj.Exec(ConnectString);
455	if Result then
456	begin
457	Protocol := GetProtocol(RegexObj.Match[1]);
458	DatabaseName := RegexObj.Match[2];
459	end
460	else
461	begin
462	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
463	Result := RegexObj.Exec(ConnectString);
464	if Result then
465	Protocol := Local {Windows with leading drive ID}
466	else
467	begin
468	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(\|/[0-9a-zA-Z\-]+):(.*)$';
469	Result := RegexObj.Exec(ConnectString);
470	if Result then
471	begin
472	{Legacy TCP Format}
473	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	Protocol := TCP;
478	end
479	else
480	begin
481	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	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	{$ELSE}
515	{cruder version of above for Delphi. Older versions lack regular expression
516	handling.}
517	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
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	{$ENDIF}
549
550	{Make a connect string in format appropriate protocol}
551
552	function MakeConnectString(ServerName, DatabaseName: AnsiString;
553	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
554
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	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	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	end;
588	end;
589
590	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
591
592	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
593	begin
594	if (Dialect = 3) and
595	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
596	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
597	else
598	Result := Value
599	end;
600
601	{Replaces unknown characters in a string with underscores}
602
603	function Space2Underscore(s: AnsiString): AnsiString;
604	var
605	k: integer;
606	begin
607	Result := s;
608	for k := 1 to Length(s) do
609	if not (Result[k] in ValidSQLIdentifierChars) then
610	Result[k] := '_';
611	end;
612
613	{Reformats an SQL string with single quotes duplicated.}
614
615	function SQLSafeString(const s: AnsiString): AnsiString;
616	begin
617	Result := StringReplace(s,'''','''''',[rfReplaceAll]);
618	end;
619
620	end.