ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/IBUtils.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 14866 byte(s)
Log Message:
Fixes Merged

File Contents

# 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.