ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
Revision: 143
Committed: Fri Feb 23 12:11:21 2018 UTC (6 years, 1 month ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/IBUtils.pas
File size: 14857 byte(s)
Log Message:
Fixes Merged

File Contents

# 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 47 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 tony 45
258     function Max(n1, n2: Integer): Integer;
259     function Min(n1, n2: Integer): Integer;
260 tony 56 function RandomString(iLength: Integer): AnsiString;
261 tony 45 function RandomInteger(iLow, iHigh: Integer): Integer;
262 tony 56 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 tony 107 function IsSQLIdentifier(Value: AnsiString): boolean;
269 tony 117 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
270 tony 143 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 tony 45
277     implementation
278    
279 tony 118 {$IFDEF HASREQEX}
280 tony 117 uses RegExpr;
281 tony 118 {$ENDIF}
282 tony 117
283 tony 45 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 tony 56 function RandomString(iLength: Integer): AnsiString;
300 tony 45 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 tony 56 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
314 tony 45 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 tony 117 {Extracts SQL Identifier typically from a Dialect 3 encoding}
325 tony 45
326 tony 117 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
327 tony 45 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 tony 117 {Returns true if "w" is a Firebird SQL reserved word}
346 tony 45
347 tony 56 function IsReservedWord(w: AnsiString): boolean;
348 tony 45 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 tony 117 {Format an SQL Identifier according to SQL Dialect}
358    
359 tony 56 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
360 tony 45 begin
361     if Dialect = 1 then
362     Value := AnsiUpperCase(Trim(Value))
363     else
364 tony 117 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
365 tony 45 Result := Value;
366     end;
367    
368 tony 107 const
369     ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
370    
371 tony 117 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
372    
373 tony 107 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 tony 117 {Extracts the Database Connect string from a Create Database Statement}
383    
384 tony 118 {$IFDEF HASREQEX}
385 tony 117 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 tony 143 ConnectString := RegexObj.Match[2];
398 tony 117 finally
399     RegexObj.Free;
400     end;
401     end;
402 tony 143
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 tony 118 {$ELSE}
490 tony 121 {cruder version of above for Delphi. Older versions lack regular expression
491     handling.}
492 tony 118 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 tony 143
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 tony 118 {$ENDIF}
524 tony 117
525 tony 143 {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 tony 117 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
555    
556 tony 56 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
557 tony 45 begin
558     if (Dialect = 3) and
559 tony 115 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
560 tony 117 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
561 tony 45 else
562     Result := Value
563     end;
564    
565 tony 117 {Replaces unknown characters in a string with underscores}
566    
567 tony 56 function Space2Underscore(s: AnsiString): AnsiString;
568 tony 45 var
569     k: integer;
570     begin
571     Result := s;
572     for k := 1 to Length(s) do
573 tony 117 if not (Result[k] in ValidSQLIdentifierChars) then
574 tony 45 Result[k] := '_';
575     end;
576    
577 tony 117 {Reformats an SQL string with single quotes duplicated.}
578    
579 tony 56 function SQLSafeString(const s: AnsiString): AnsiString;
580 tony 47 begin
581     Result := StringReplace(s,'''','''''',[rfReplaceAll]);
582     end;
583 tony 45
584     end.