udr/client/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..197] 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',
  '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:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/fbintf/IBUtils.pas*
File size:	14857 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..197] 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	'LEADING',
150	'LEFT',
151	'LIKE',
152	'LONG',
153	'LOWER',
154	'MAX',
155	'MAXIMUM_SEGMENT',
156	'MERGE',
157	'MIN',
158	'MINUTE',
159	'MONTH',
160	'NATIONAL',
161	'NATURAL',
162	'NCHAR',
163	'NO',
164	'NOT',
165	'NULL',
166	'NUMERIC',
167	'OCTET_LENGTH',
168	'OF',
169	'OFFSET',
170	'ON',
171	'ONLY',
172	'OPEN',
173	'OR',
174	'ORDER',
175	'OUTER',
176	'OVER',
177	'PARAMETER',
178	'PLAN',
179	'POSITION',
180	'POST_EVENT',
181	'PRECISION',
182	'PRIMARY',
183	'PROCEDURE',
184	'RDB$DB_KEY',
185	'RDB$RECORD_VERSION',
186	'REAL',
187	'RECORD_VERSION',
188	'RECREATE',
189	'RECURSIVE',
190	'REFERENCES',
191	'REGR_AVGX',
192	'REGR_AVGY',
193	'REGR_COUNT',
194	'REGR_INTERCEPT',
195	'REGR_R2',
196	'REGR_SLOPE',
197	'REGR_SXX',
198	'REGR_SXY',
199	'REGR_SYY',
200	'RELEASE',
201	'RETURN',
202	'RETURNING_VALUES',
203	'RETURNS',
204	'REVOKE',
205	'RIGHT',
206	'ROLLBACK',
207	'ROW',
208	'ROW_COUNT',
209	'ROWS',
210	'SAVEPOINT',
211	'SCROLL',
212	'SECOND',
213	'SELECT',
214	'SENSITIVE',
215	'SET',
216	'SIMILAR',
217	'SMALLINT',
218	'SOME',
219	'SQLCODE',
220	'SQLSTATE',
221	'SQLSTATE',
222	'START',
223	'STDDEV_POP',
224	'STDDEV_SAMP',
225	'SUM',
226	'TABLE',
227	'THEN',
228	'TIME',
229	'TIMESTAMP',
230	'TO',
231	'TRAILING',
232	'TRIGGER',
233	'TRIM',
234	'TRUE',
235	'UNION',
236	'UNIQUE',
237	'UNKNOWN',
238	'UPDATE',
239	'UPDATING',
240	'UPPER',
241	'USER',
242	'USING',
243	'VALUE',
244	'VALUES',
245	'VAR_POP',
246	'VAR_SAMP',
247	'VARCHAR',
248	'VARIABLE',
249	'VARYING',
250	'VIEW',
251	'WHEN',
252	'WHERE',
253	'WHILE',
254	'WITH',
255	'YEAR'
256	);
257
258	function Max(n1, n2: Integer): Integer;
259	function Min(n1, n2: Integer): Integer;
260	function RandomString(iLength: Integer): AnsiString;
261	function RandomInteger(iLow, iHigh: Integer): Integer;
262	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
263	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
264	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
265	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
266	function Space2Underscore(s: AnsiString): AnsiString;
267	function SQLSafeString(const s: AnsiString): AnsiString;
268	function IsSQLIdentifier(Value: AnsiString): boolean;
269	function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
270	function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
271	PortNo: AnsiString = ''): AnsiString;
272	function ParseConnectString(ConnectString: AnsiString;
273	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
274	var PortNo: AnsiString): boolean;
275	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
276
277	implementation
278
279	{$IFDEF HASREQEX}
280	uses RegExpr;
281	{$ENDIF}
282
283	function Max(n1, n2: Integer): Integer;
284	begin
285	if (n1 > n2) then
286	result := n1
287	else
288	result := n2;
289	end;
290
291	function Min(n1, n2: Integer): Integer;
292	begin
293	if (n1 < n2) then
294	result := n1
295	else
296	result := n2;
297	end;
298
299	function RandomString(iLength: Integer): AnsiString;
300	begin
301	result := '';
302	while Length(result) < iLength do
303	result := result + IntToStr(RandomInteger(0, High(Integer)));
304	if Length(result) > iLength then
305	result := Copy(result, 1, iLength);
306	end;
307
308	function RandomInteger(iLow, iHigh: Integer): Integer;
309	begin
310	result := Trunc(Random(iHigh - iLow)) + iLow;
311	end;
312
313	function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
314	var
315	i: Integer;
316	begin
317	result := '';
318	for i := 1 to Length(st) do begin
319	if AnsiPos(st[i], CharsToStrip) = 0 then
320	result := result + st[i];
321	end;
322	end;
323
324	{Extracts SQL Identifier typically from a Dialect 3 encoding}
325
326	function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
327	begin
328	Value := Trim(Value);
329	if Dialect = 1 then
330	Value := AnsiUpperCase(Value)
331	else
332	begin
333	if (Value <> '') and (Value[1] = '"') then
334	begin
335	Delete(Value, 1, 1);
336	Delete(Value, Length(Value), 1);
337	Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
338	end
339	else
340	Value := AnsiUpperCase(Value);
341	end;
342	Result := Value;
343	end;
344
345	{Returns true if "w" is a Firebird SQL reserved word}
346
347	function IsReservedWord(w: AnsiString): boolean;
348	var i: integer;
349	begin
350	Result := true;
351	for i := 0 to Length(sqlReservedWords) - 1 do
352	if w = sqlReservedWords[i] then
353	Exit;
354	Result := false;
355	end;
356
357	{Format an SQL Identifier according to SQL Dialect}
358
359	function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
360	begin
361	if Dialect = 1 then
362	Value := AnsiUpperCase(Trim(Value))
363	else
364	Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
365	Result := Value;
366	end;
367
368	const
369	ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
370
371	{Returns true if the value is a valid SQL Identifier - note lower case accepted}
372
373	function IsSQLIdentifier(Value: AnsiString): boolean;
374	var i: integer;
375	begin
376	Result := false;
377	for i := 1 to Length(Value) do
378	if not (Value[i] in ValidSQLIdentifierChars) then Exit;
379	Result := true;
380	end;
381
382	{Extracts the Database Connect string from a Create Database Statement}
383
384	{$IFDEF HASREQEX}
385	function ExtractConnectString(const CreateSQL: AnsiString;
386	var ConnectString: AnsiString): boolean;
387	var RegexObj: TRegExpr;
388	begin
389	RegexObj := TRegExpr.Create;
390	try
391	{extact database file spec}
392	RegexObj.ModifierG := false; {turn off greedy matches}
393	RegexObj.ModifierI := true; {case insensitive match}
394	RegexObj.Expression := '^ CREATE +(DATABASE\|SCHEMA) +''(.)''';
395	Result := RegexObj.Exec(CreateSQL);
396	if Result then
397	ConnectString := RegexObj.Match[2];
398	finally
399	RegexObj.Free;
400	end;
401	end;
402
403	function ParseConnectString(ConnectString: AnsiString; var ServerName,
404	DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
405	): boolean;
406	var RegexObj: TRegExpr;
407	scheme: AnsiString;
408	begin
409	ServerName := '';
410	DatabaseName := ConnectString;
411	PortNo := '';
412	Protocol := unknownProtocol;
413	RegexObj := TRegExpr.Create;
414	try
415	{extact database file spec}
416	RegexObj.ModifierG := false; {turn off greedy matches}
417	RegexObj.Expression := '^([a-zA-Z]+)://([a-zA-Z0-9\-\.]+)(\|:[0-9a-zA-Z\-]+)/(.*)$';
418	Result := RegexObj.Exec(ConnectString);
419	if Result then
420	begin
421	{URL type connect string}
422	scheme := AnsiUpperCase(RegexObj.Match[1]);
423	ServerName := RegexObj.Match[2];
424	if RegexObj.MatchLen[3] > 0 then
425	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
426	DatabaseName := RegexObj.Match[4];
427	if scheme = 'INET' then
428	Protocol := inet
429	else
430	if scheme = 'XNET' then
431	Protocol := xnet
432	else
433	if scheme = 'WNET' then
434	Protocol := wnet
435	end
436	else
437	begin
438	RegexObj.Expression := '^([a-zA-Z]:\\.*)';
439	Result := RegexObj.Exec(ConnectString);
440	if Result then
441	Protocol := Local {Windows with leading drive ID}
442	else
443	begin
444	RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(\|/[0-9a-zA-Z\-]+):(.*)$';
445	Result := RegexObj.Exec(ConnectString);
446	if Result then
447	begin
448	{Legacy TCP Format}
449	ServerName := RegexObj.Match[1];
450	if RegexObj.MatchLen[2] > 0 then
451	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
452	DatabaseName := RegexObj.Match[3];
453	Protocol := TCP;
454	end
455	else
456	begin
457	RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(\|@[0-9a-zA-Z\-]+)\\(.*)$';
458	Result := RegexObj.Exec(ConnectString);
459	if Result then
460	begin
461	{Netbui}
462	ServerName := RegexObj.Match[1];
463	if RegexObj.MatchLen[2] > 0 then
464	PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
465	DatabaseName := RegexObj.Match[3];
466	Protocol := NamedPipe
467	end
468	else
469	begin
470	Result := true;
471	Protocol := Local; {Assume local}
472	end;
473	end;
474	end;
475	end;
476	finally
477	RegexObj.Free;
478	end;
479	end;
480
481	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
482	var ServerName,
483	DatabaseName: AnsiString;
484	PortNo: AnsiString;
485	begin
486	ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
487	end;
488
489	{$ELSE}
490	{cruder version of above for Delphi. Older versions lack regular expression
491	handling.}
492	function ExtractConnectString(const CreateSQL: AnsiString;
493	var ConnectString: AnsiString): boolean;
494	var i: integer;
495	begin
496	Result := false;
497	i := Pos('''',CreateSQL);
498	if i > 0 then
499	begin
500	ConnectString := CreateSQL;
501	delete(ConnectString,1,i);
502	i := Pos('''',ConnectString);
503	if i > 0 then
504	begin
505	delete(ConnectString,i,Length(ConnectString)-i+1);
506	Result := true;
507	end;
508	end;
509	end;
510
511	function GetProtocol(ConnectString: AnsiString): TProtocolAll;
512	begin
513	Result := unknownProtocol; {not implemented for Delphi}
514	end;
515
516	function ParseConnectString(ConnectString: AnsiString;
517	var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
518	var PortNo: AnsiString): boolean;
519	begin
520	Result := false;
521	end;
522
523	{$ENDIF}
524
525	{Make a connect string in format appropriate protocol}
526
527	function MakeConnectString(ServerName, DatabaseName: AnsiString;
528	Protocol: TProtocol; PortNo: AnsiString): AnsiString;
529	begin
530	if PortNo <> '' then
531	case Protocol of
532	NamedPipe:
533	ServerName := ServerName + '@' + PortNo;
534	Local,
535	SPX,
536	xnet: {do nothing};
537	TCP:
538	ServerName := ServerName + '/' + PortNo;
539	else
540	ServerName := ServerName + ':' + PortNo;
541	end;
542
543	case Protocol of
544	TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
545	SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
546	NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
547	Local: Result := DatabaseName; {do not localize}
548	inet: Result := 'inet://' + ServerName + '/'+ DatabaseName; {do not localize}
549	wnet: Result := 'wnet://' + ServerName + '/'+ DatabaseName; {do not localize}
550	xnet: Result := 'xnet://' + ServerName + '/'+ DatabaseName; {do not localize}
551	end;
552	end;
553
554	{Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
555
556	function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
557	begin
558	if (Dialect = 3) and
559	(IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
560	Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
561	else
562	Result := Value
563	end;
564
565	{Replaces unknown characters in a string with underscores}
566
567	function Space2Underscore(s: AnsiString): AnsiString;
568	var
569	k: integer;
570	begin
571	Result := s;
572	for k := 1 to Length(s) do
573	if not (Result[k] in ValidSQLIdentifierChars) then
574	Result[k] := '_';
575	end;
576
577	{Reformats an SQL string with single quotes duplicated.}
578
579	function SQLSafeString(const s: AnsiString): AnsiString;
580	begin
581	Result := StringReplace(s,'''','''''',[rfReplaceAll]);
582	end;
583
584	end.