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;
var RegexObj: TRegExpr;
    scheme: AnsiString;
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-Z]+)://([a-zA-Z0-9\-\.]+)(|:[0-9a-zA-Z\-]+)/(.*)$';
    Result := RegexObj.Exec(ConnectString);
    if Result then
    begin
      {URL type connect string}
      scheme := AnsiUpperCase(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 scheme = 'INET' then
        Protocol := inet
      else
      if scheme = 'XNET' then
        Protocol := xnet
      else
      if scheme = 'WNET' then
        Protocol := wnet
    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;
  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;
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://' + ServerName + '/'+ DatabaseName; {do not localize}
    wnet:       Result := 'wnet://' + ServerName + '/'+ DatabaseName; {do not localize}
    xnet:       Result := 'xnet://' + ServerName + '/'+ DatabaseName;  {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:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	14866 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	var RegexObj: TRegExpr;
408	scheme: AnsiString;
409	begin
410	ServerName := '';
411	DatabaseName := ConnectString;
412	PortNo := '';
413	Protocol := unknownProtocol;
414	RegexObj := TRegExpr.Create;
415	try
416	{extact database file spec}
417	RegexObj.ModifierG := false; {turn off greedy matches}
418	RegexObj.Expression := '^([a-zA-Z]+)://([a-zA-Z0-9\-\.]+)(\|:[0-9a-zA-Z\-]+)/(.*)$';
419	Result := RegexObj.Exec(ConnectString);
420	if Result then
421	begin
422	{URL type connect string}
423	scheme := AnsiUpperCase(RegexObj.Match[1]);
424	ServerName := RegexObj.Match[2];
425	if RegexObj.MatchLen[3] > 0 then
426	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
427	DatabaseName := RegexObj.Match[4];
428	if scheme = 'INET' then
429	Protocol := inet
430	else
431	if scheme = 'XNET' then
432	Protocol := xnet
433	else
434	if scheme = 'WNET' then
435	Protocol := wnet
436	end
437	else
438	begin
439	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
440	Result := RegexObj.Exec(ConnectString);
441	if Result then
442	Protocol := Local {Windows with leading drive ID}
443	else
444	begin
445	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(\|/[0-9a-zA-Z\-]+):(.*)$';
446	Result := RegexObj.Exec(ConnectString);
447	if Result then
448	begin
449	{Legacy TCP Format}
450	ServerName := RegexObj.Match[1];
451	if RegexObj.MatchLen[2] > 0 then
452	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
453	DatabaseName := RegexObj.Match[3];
454	Protocol := TCP;
455	end
456	else
457	begin
458	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(\|@[0-9a-zA-Z\-]+)\\(.*)$';
459	Result := RegexObj.Exec(ConnectString);
460	if Result then
461	begin
462	{Netbui}
463	ServerName := RegexObj.Match[1];
464	if RegexObj.MatchLen[2] > 0 then
465	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
466	DatabaseName := RegexObj.Match[3];
467	Protocol := NamedPipe
468	end
469	else
470	begin
471	Result := true;
472	Protocol := Local; {Assume local}
473	end;
474	end;
475	end;
476	end;
477	finally
478	RegexObj.Free;
479	end;
480	end;
481
482	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
483	var ServerName,
484	DatabaseName: AnsiString;
485	PortNo: AnsiString;
486	begin
487	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
488	end;
489
490	{$ELSE}
491	{cruder version of above for Delphi. Older versions lack regular expression
492	handling.}
493	function ExtractConnectString(const CreateSQL: AnsiString;
494	var ConnectString: AnsiString): boolean;
495	var i: integer;
496	begin
497	Result := false;
498	i := Pos('''',CreateSQL);
499	if i > 0 then
500	begin
501	ConnectString := CreateSQL;
502	delete(ConnectString,1,i);
503	i := Pos('''',ConnectString);
504	if i > 0 then
505	begin
506	delete(ConnectString,i,Length(ConnectString)-i+1);
507	Result := true;
508	end;
509	end;
510	end;
511
512	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
513	begin
514	Result := unknownProtocol; {not implemented for Delphi}
515	end;
516
517	function ParseConnectString(ConnectString: AnsiString;
518	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
519	var PortNo: AnsiString): boolean;
520	begin
521	Result := false;
522	end;
523
524	{$ENDIF}
525
526	{Make a connect string in format appropriate protocol}
527
528	function MakeConnectString(ServerName, DatabaseName: AnsiString;
529	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
530	begin
531	if PortNo <> '' then
532	case Protocol of
533	NamedPipe:
534	ServerName := ServerName + '@' + PortNo;
535	Local,
536	SPX,
537	xnet: {do nothing};
538	TCP:
539	ServerName := ServerName + '/' + PortNo;
540	else
541	ServerName := ServerName + ':' + PortNo;
542	end;
543
544	case Protocol of
545	TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
546	SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
547	NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
548	Local: Result := DatabaseName; {do not localize}
549	inet: Result := 'inet://' + ServerName + '/'+ DatabaseName; {do not localize}
550	wnet: Result := 'wnet://' + ServerName + '/'+ DatabaseName; {do not localize}
551	xnet: Result := 'xnet://' + ServerName + '/'+ DatabaseName; {do not localize}
552	end;
553	end;
554
555	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
556
557	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
558	begin
559	if (Dialect = 3) and
560	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
561	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
562	else
563	Result := Value
564	end;
565
566	{Replaces unknown characters in a string with underscores}
567
568	function Space2Underscore(s: AnsiString): AnsiString;
569	var
570	k: integer;
571	begin
572	Result := s;
573	for k := 1 to Length(s) do
574	if not (Result[k] in ValidSQLIdentifierChars) then
575	Result[k] := '_';
576	end;
577
578	{Reformats an SQL string with single quotes duplicated.}
579
580	function SQLSafeString(const s: AnsiString): AnsiString;
581	begin
582	Result := StringReplace(s,'''','''''',[rfReplaceAll]);
583	end;
584
585	end.