ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/journaling/fbintf/IBUtils.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/IBUtils.pas
File size: 32015 byte(s)
Log Message:
Release 2.3.2 committed

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 type
51 TSQLTokens = (
52
53 {Reserved Words}
54
55 sqltAdd,
56 sqltAdmin,
57 sqltAll,
58 sqltAlter,
59 sqltAnd,
60 sqltAny,
61 sqltAs,
62 sqltAt,
63 sqltAvg,
64 sqltBegin,
65 sqltBetween,
66 sqltBigint,
67 sqltBit_Length,
68 sqltBlob,
69 sqltBoolean,
70 sqltBoth,
71 sqltBy,
72 sqltCase,
73 sqltCast,
74 sqltChar,
75 sqltChar_Length,
76 sqltCharacter,
77 sqltCharacter_Length,
78 sqltCheck,
79 sqltClose,
80 sqltCollate,
81 sqltColumn,
82 sqltCommit,
83 sqltConnect,
84 sqltConstraint,
85 sqltCorr,
86 sqltCount,
87 sqltCovar_Pop,
88 sqltCovar_Samp,
89 sqltCreate,
90 sqltCross,
91 sqltCurrent,
92 sqltCurrent_Connection,
93 sqltCurrent_Date,
94 sqltCurrent_Role,
95 sqltCurrent_Time,
96 sqltCurrent_Timestamp,
97 sqltCurrent_Transaction,
98 sqltCurrent_User,
99 sqltCursor,
100 sqltDate,
101 sqltDay,
102 sqltDec,
103 sqltDecimal,
104 sqltDeclare,
105 sqltDefault,
106 sqltDelete,
107 sqltDeleting,
108 sqltDeterministic,
109 sqltDisconnect,
110 sqltDistinct,
111 sqltDouble,
112 sqltDrop,
113 sqltElse,
114 sqltEnd,
115 sqltEscape,
116 sqltExecute,
117 sqltExists,
118 sqltExternal,
119 sqltExtract,
120 sqltFalse,
121 sqltFetch,
122 sqltFilter,
123 sqltFloat,
124 sqltFor,
125 sqltForeign,
126 sqltFrom,
127 sqltFull,
128 sqltFunction,
129 sqltGdscode,
130 sqltGlobal,
131 sqltGrant,
132 sqltGroup,
133 sqltHaving,
134 sqltHour,
135 sqltIn,
136 sqltIndex,
137 sqltInner,
138 sqltInsensitive,
139 sqltInsert,
140 sqltInserting,
141 sqltInt,
142 sqltInteger,
143 sqltInto,
144 sqltIs,
145 sqltJoin,
146 sqltKey,
147 sqltLeading,
148 sqltLeft,
149 sqltLike,
150 sqltLong,
151 sqltLower,
152 sqltMax,
153 sqltMaximum_Segment,
154 sqltMerge,
155 sqltMin,
156 sqltMinute,
157 sqltMonth,
158 sqltNational,
159 sqltNatural,
160 sqltNchar,
161 sqltNo,
162 sqltNot,
163 sqltNull,
164 sqltNumeric,
165 sqltOctet_Length,
166 sqltOf,
167 sqltOffset,
168 sqltOn,
169 sqltOnly,
170 sqltOpen,
171 sqltOr,
172 sqltOrder,
173 sqltOuter,
174 sqltOver,
175 sqltParameter,
176 sqltPlan,
177 sqltPosition,
178 sqltPost_Event,
179 sqltPrecision,
180 sqltPrimary,
181 sqltProcedure,
182 sqltRdbDb_Key,
183 sqltRdbRecord_Version,
184 sqltReal,
185 sqltRecord_Version,
186 sqltRecreate,
187 sqltRecursive,
188 sqltReferences,
189 sqltRegr_Avgx,
190 sqltRegr_Avgy,
191 sqltRegr_Count,
192 sqltRegr_Intercept,
193 sqltRegr_R2,
194 sqltRegr_Slope,
195 sqltRegr_Sxx,
196 sqltRegr_Sxy,
197 sqltRegr_Syy,
198 sqltRelease,
199 sqltReturn,
200 sqltReturning_Values,
201 sqltReturns,
202 sqltRevoke,
203 sqltRight,
204 sqltRollback,
205 sqltRow,
206 sqltRows,
207 sqltRow_Count,
208 sqltSavepoint,
209 sqltScroll,
210 sqltSecond,
211 sqltSelect,
212 sqltSensitive,
213 sqltSet,
214 sqltSimilar,
215 sqltSmallint,
216 sqltSome,
217 sqltSqlcode,
218 sqltSqlstate,
219 sqltStart,
220 sqltStddev_Pop,
221 sqltStddev_Samp,
222 sqltSum,
223 sqltTable,
224 sqltThen,
225 sqltTime,
226 sqltTimestamp,
227 sqltTo,
228 sqltTrailing,
229 sqltTrigger,
230 sqltTrim,
231 sqltTrue,
232 sqltUnion,
233 sqltUnique,
234 sqltUnknown,
235 sqltUpdate,
236 sqltUpdating,
237 sqltUpper,
238 sqltUser,
239 sqltUsing,
240 sqltValue,
241 sqltValues,
242 sqltVar_Pop,
243 sqltVar_Samp,
244 sqltVarchar,
245 sqltVariable,
246 sqltVarying,
247 sqltView,
248 sqltWhen,
249 sqltWhere,
250 sqltWhile,
251 sqltWith,
252 sqltYear,
253
254 {symbols}
255
256 sqltSpace,
257 sqltSemiColon,
258 sqltPlaceholder,
259 sqltSingleQuotes,
260 sqltDoubleQuotes,
261 sqltComma,
262 sqltPeriod,
263 sqltEquals,
264 sqltOtherCharacter,
265 sqltIdentifier,
266 sqltIdentifierInDoubleQuotes,
267 sqltNumberString,
268 sqltString,
269 sqltParam,
270 sqltQuotedParam,
271 sqltColon,
272 sqltComment,
273 sqltCommentLine,
274 sqltQuotedString,
275 sqltAsterisk,
276 sqltForwardSlash,
277 sqltOpenSquareBracket,
278 sqltCloseSquareBracket,
279 sqltOpenBracket,
280 sqltCloseBracket,
281 sqltPipe,
282 sqltConcatSymbol,
283 sqltLT,
284 sqltGT,
285 sqltCR,
286 sqltEOL,
287 sqltEOF,
288 sqltInit
289 );
290
291 TSQLReservedWords = sqltAdd..sqltYear;
292
293 const
294 CRLF = #13 + #10;
295 CR = #13;
296 LF = #10;
297 TAB = #9;
298 NULL_TERMINATOR = #0;
299
300 {$IFNDEF FPC}
301 LineEnding = CRLF;
302 {$ENDIF}
303
304 {SQL Reserved words in alphabetical order}
305
306 sqlReservedWords: array [TSQLReservedWords] of string = (
307 'ADD',
308 'ADMIN',
309 'ALL',
310 'ALTER',
311 'AND',
312 'ANY',
313 'AS',
314 'AT',
315 'AVG',
316 'BEGIN',
317 'BETWEEN',
318 'BIGINT',
319 'BIT_LENGTH',
320 'BLOB',
321 'BOOLEAN',
322 'BOTH',
323 'BY',
324 'CASE',
325 'CAST',
326 'CHAR',
327 'CHAR_LENGTH',
328 'CHARACTER',
329 'CHARACTER_LENGTH',
330 'CHECK',
331 'CLOSE',
332 'COLLATE',
333 'COLUMN',
334 'COMMIT',
335 'CONNECT',
336 'CONSTRAINT',
337 'CORR',
338 'COUNT',
339 'COVAR_POP',
340 'COVAR_SAMP',
341 'CREATE',
342 'CROSS',
343 'CURRENT',
344 'CURRENT_CONNECTION',
345 'CURRENT_DATE',
346 'CURRENT_ROLE',
347 'CURRENT_TIME',
348 'CURRENT_TIMESTAMP',
349 'CURRENT_TRANSACTION',
350 'CURRENT_USER',
351 'CURSOR',
352 'DATE',
353 'DAY',
354 'DEC',
355 'DECIMAL',
356 'DECLARE',
357 'DEFAULT',
358 'DELETE',
359 'DELETING',
360 'DETERMINISTIC',
361 'DISCONNECT',
362 'DISTINCT',
363 'DOUBLE',
364 'DROP',
365 'ELSE',
366 'END',
367 'ESCAPE',
368 'EXECUTE',
369 'EXISTS',
370 'EXTERNAL',
371 'EXTRACT',
372 'FALSE',
373 'FETCH',
374 'FILTER',
375 'FLOAT',
376 'FOR',
377 'FOREIGN',
378 'FROM',
379 'FULL',
380 'FUNCTION',
381 'GDSCODE',
382 'GLOBAL',
383 'GRANT',
384 'GROUP',
385 'HAVING',
386 'HOUR',
387 'IN',
388 'INDEX',
389 'INNER',
390 'INSENSITIVE',
391 'INSERT',
392 'INSERTING',
393 'INT',
394 'INTEGER',
395 'INTO',
396 'IS',
397 'JOIN',
398 'KEY',
399 'LEADING',
400 'LEFT',
401 'LIKE',
402 'LONG',
403 'LOWER',
404 'MAX',
405 'MAXIMUM_SEGMENT',
406 'MERGE',
407 'MIN',
408 'MINUTE',
409 'MONTH',
410 'NATIONAL',
411 'NATURAL',
412 'NCHAR',
413 'NO',
414 'NOT',
415 'NULL',
416 'NUMERIC',
417 'OCTET_LENGTH',
418 'OF',
419 'OFFSET',
420 'ON',
421 'ONLY',
422 'OPEN',
423 'OR',
424 'ORDER',
425 'OUTER',
426 'OVER',
427 'PARAMETER',
428 'PLAN',
429 'POSITION',
430 'POST_EVENT',
431 'PRECISION',
432 'PRIMARY',
433 'PROCEDURE',
434 'RDB$DB_KEY',
435 'RDB$RECORD_VERSION',
436 'REAL',
437 'RECORD_VERSION',
438 'RECREATE',
439 'RECURSIVE',
440 'REFERENCES',
441 'REGR_AVGX',
442 'REGR_AVGY',
443 'REGR_COUNT',
444 'REGR_INTERCEPT',
445 'REGR_R2',
446 'REGR_SLOPE',
447 'REGR_SXX',
448 'REGR_SXY',
449 'REGR_SYY',
450 'RELEASE',
451 'RETURN',
452 'RETURNING_VALUES',
453 'RETURNS',
454 'REVOKE',
455 'RIGHT',
456 'ROLLBACK',
457 'ROW',
458 'ROWS',
459 'ROW_COUNT',
460 'SAVEPOINT',
461 'SCROLL',
462 'SECOND',
463 'SELECT',
464 'SENSITIVE',
465 'SET',
466 'SIMILAR',
467 'SMALLINT',
468 'SOME',
469 'SQLCODE',
470 'SQLSTATE',
471 'START',
472 'STDDEV_POP',
473 'STDDEV_SAMP',
474 'SUM',
475 'TABLE',
476 'THEN',
477 'TIME',
478 'TIMESTAMP',
479 'TO',
480 'TRAILING',
481 'TRIGGER',
482 'TRIM',
483 'TRUE',
484 'UNION',
485 'UNIQUE',
486 'UNKNOWN',
487 'UPDATE',
488 'UPDATING',
489 'UPPER',
490 'USER',
491 'USING',
492 'VALUE',
493 'VALUES',
494 'VAR_POP',
495 'VAR_SAMP',
496 'VARCHAR',
497 'VARIABLE',
498 'VARYING',
499 'VIEW',
500 'WHEN',
501 'WHERE',
502 'WHILE',
503 'WITH',
504 'YEAR'
505 );
506
507 type
508 {The TSQLTokeniser class provides a common means to parse an SQL statement, or
509 even a stream of SQL Statements. The TSQLStringTokeniser class is instantiated
510 with a single SQL statement or a set of concatenated statements. The TSQLStreamTokeniser
511 is instantiated with a stream from which the SQL statements are read.
512
513 Successive calls to GetNextToken then return each SQL token. The TokenText contains
514 either the single character, the identifier or reserved word, the string or comment.}
515
516 { TSQLTokeniser }
517
518 TSQLTokeniser = class
519 private
520 const
521 TokenQueueMaxSize = 64;
522 type
523 TLexState = (stDefault, stInCommentLine, stInComment, stSingleQuoted, stDoubleQuoted,
524 stInIdentifier, stInNumeric);
525
526 TTokenQueueItem = record
527 token: TSQLTokens;
528 text: AnsiString;
529 end;
530 TTokenQueueState = (tsHold, tsRelease);
531
532 private
533 FLastChar: AnsiChar;
534 FState: TLexState;
535 FSkipNext: boolean;
536 function GetNext: TSQLTokens;
537
538 {The token Queue is available for use by descendents so that they can
539 hold back tokens in order to lookahead by token rather than just a single
540 character}
541
542 private
543 FTokenQueue: array[0..TokenQueueMaxSize] of TTokenQueueItem;
544 FQueueState: TTokenQueueState;
545 FQFirst: integer; {first and last pointers first=last => queue empty}
546 FQLast: integer;
547 FEOF: boolean;
548 procedure PopQueue(var token: TSQLTokens);
549 protected
550 FString: AnsiString;
551 FNextToken: TSQLTokens;
552 procedure Assign(source: TSQLTokeniser); virtual;
553 function GetChar: AnsiChar; virtual; abstract;
554 function TokenFound(var token: TSQLTokens): boolean; virtual;
555 function InternalGetNextToken: TSQLTokens; virtual;
556 procedure Reset; virtual;
557
558 {Token stack}
559 procedure QueueToken(token: TSQLTokens; text:AnsiString); overload;
560 procedure QueueToken(token: TSQLTokens); overload;
561 procedure ResetQueue; overload;
562 procedure ResetQueue(token: TSQLTokens; text:AnsiString); overload;
563 procedure ResetQueue(token: TSQLTokens); overload;
564 procedure ReleaseQueue(var token: TSQLTokens); overload;
565 procedure ReleaseQueue; overload;
566 function GetQueuedText: AnsiString;
567 procedure SetTokenText(text: AnsiString);
568
569 public
570 const
571 DefaultTerminator = ';';
572 public
573 constructor Create;
574 destructor Destroy; override;
575 function GetNextToken: TSQLTokens;
576 property EOF: boolean read FEOF;
577 property TokenText: AnsiString read FString;
578 end;
579
580 { TSQLwithNamedParamsTokeniser }
581
582 TSQLwithNamedParamsTokeniser = class(TSQLTokeniser)
583 private
584 type
585 TSQLState = (stInit,stInParam,stInBlock, stInArrayDim);
586 private
587 FState: TSQLState;
588 FNested: integer;
589 protected
590 procedure Assign(source: TSQLTokeniser); override;
591 procedure Reset; override;
592 function TokenFound(var token: TSQLTokens): boolean; override;
593 end;
594
595 function Max(n1, n2: Integer): Integer;
596 function Min(n1, n2: Integer): Integer;
597 function RandomString(iLength: Integer): AnsiString;
598 function RandomInteger(iLow, iHigh: Integer): Integer;
599 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
600 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
601 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
602 function IsReservedWord(w: AnsiString): boolean;
603 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
604 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
605 function Space2Underscore(s: AnsiString): AnsiString;
606 function SQLSafeString(const s: AnsiString): AnsiString;
607 function IsSQLIdentifier(Value: AnsiString): boolean;
608 function ExtractConnectString(const CreateSQL: AnsiString; var ConnectString: AnsiString): boolean;
609 function MakeConnectString(ServerName, DatabaseName: AnsiString; Protocol: TProtocol;
610 PortNo: AnsiString = ''): AnsiString;
611 function ParseConnectString(ConnectString: AnsiString;
612 var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
613 var PortNo: AnsiString): boolean;
614 function GetProtocol(ConnectString: AnsiString): TProtocolAll;
615
616 implementation
617
618 uses FBMessages
619
620 {$IFDEF HASREQEX}
621 ,RegExpr
622 {$ENDIF};
623
624 function Max(n1, n2: Integer): Integer;
625 begin
626 if (n1 > n2) then
627 result := n1
628 else
629 result := n2;
630 end;
631
632 function Min(n1, n2: Integer): Integer;
633 begin
634 if (n1 < n2) then
635 result := n1
636 else
637 result := n2;
638 end;
639
640 function RandomString(iLength: Integer): AnsiString;
641 begin
642 result := '';
643 while Length(result) < iLength do
644 result := result + IntToStr(RandomInteger(0, High(Integer)));
645 if Length(result) > iLength then
646 result := Copy(result, 1, iLength);
647 end;
648
649 function RandomInteger(iLow, iHigh: Integer): Integer;
650 begin
651 result := Trunc(Random(iHigh - iLow)) + iLow;
652 end;
653
654 function StripString(st: AnsiString; CharsToStrip: AnsiString): AnsiString;
655 var
656 i: Integer;
657 begin
658 result := '';
659 for i := 1 to Length(st) do begin
660 if AnsiPos(st[i], CharsToStrip) = 0 then
661 result := result + st[i];
662 end;
663 end;
664
665 {Extracts SQL Identifier typically from a Dialect 3 encoding}
666
667 function ExtractIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
668 begin
669 Value := Trim(Value);
670 if Dialect = 1 then
671 Value := AnsiUpperCase(Value)
672 else
673 begin
674 if (Value <> '') and (Value[1] = '"') then
675 begin
676 Delete(Value, 1, 1);
677 Delete(Value, Length(Value), 1);
678 Value := StringReplace (Value, '""', '"', [rfReplaceAll]);
679 end
680 else
681 Value := AnsiUpperCase(Value);
682 end;
683 Result := Value;
684 end;
685
686 {Returns true if "w" is a Firebird SQL reserved word, and the
687 corresponding TSQLTokens value.}
688
689 function FindReservedWord(w: AnsiString; var token: TSQLTokens): boolean;
690 var i: TSQLTokens;
691 begin
692 Result := true;
693 w := AnsiUpperCase(Trim(w));
694 for i := Low(TSQLReservedWords) to High(TSQLReservedWords) do
695 begin
696 if w = sqlReservedWords[i] then
697 begin
698 token := i;
699 Exit;
700 end;
701 if w < sqlReservedWords[i] then
702 break;
703 end;
704 Result := false;
705 end;
706
707 {Returns true if "w" is a Firebird SQL reserved word}
708
709 function IsReservedWord(w: AnsiString): boolean;
710 var token: TSQLTokens;
711 begin
712 Result := FindReservedWord(w,token);
713 end;
714
715 {Format an SQL Identifier according to SQL Dialect}
716
717 function QuoteIdentifier(Dialect: Integer; Value: AnsiString): AnsiString;
718 begin
719 if Dialect = 1 then
720 Value := AnsiUpperCase(Trim(Value))
721 else
722 Value := '"' + StringReplace (Value, '""', '"', [rfReplaceAll]) + '"';
723 Result := Value;
724 end;
725
726 const
727 ValidSQLIdentifierChars = ['A'..'Z','a'..'z','0'..'9','_','$'];
728
729 {Returns true if the value is a valid SQL Identifier - note lower case accepted}
730
731 function IsSQLIdentifier(Value: AnsiString): boolean;
732 var i: integer;
733 begin
734 Result := false;
735 for i := 1 to Length(Value) do
736 if not (Value[i] in ValidSQLIdentifierChars) then Exit;
737 Result := true;
738 end;
739
740 {Extracts the Database Connect string from a Create Database Statement}
741
742 {$IFDEF HASREQEX}
743 function ExtractConnectString(const CreateSQL: AnsiString;
744 var ConnectString: AnsiString): boolean;
745 var RegexObj: TRegExpr;
746 begin
747 RegexObj := TRegExpr.Create;
748 try
749 {extact database file spec}
750 RegexObj.ModifierG := false; {turn off greedy matches}
751 RegexObj.ModifierI := true; {case insensitive match}
752 RegexObj.Expression := '^ *CREATE +(DATABASE|SCHEMA) +''(.*)''';
753 Result := RegexObj.Exec(CreateSQL);
754 if Result then
755 ConnectString := RegexObj.Match[2];
756 finally
757 RegexObj.Free;
758 end;
759 end;
760
761 function ParseConnectString(ConnectString: AnsiString; var ServerName,
762 DatabaseName: AnsiString; var Protocol: TProtocolAll; var PortNo: AnsiString
763 ): boolean;
764
765 function GetProtocol(scheme: AnsiString): TProtocolAll;
766 begin
767 scheme := AnsiUpperCase(scheme);
768 if scheme = 'INET' then
769 Result := inet
770 else
771 if scheme = 'INET4' then
772 Result := inet4
773 else
774 if scheme = 'INET6' then
775 Result := inet6
776 else
777 if scheme = 'XNET' then
778 Result := xnet
779 else
780 if scheme = 'WNET' then
781 Result := wnet
782 end;
783
784 var RegexObj: TRegExpr;
785 begin
786 ServerName := '';
787 DatabaseName := ConnectString;
788 PortNo := '';
789 Protocol := unknownProtocol;
790 RegexObj := TRegExpr.Create;
791 try
792 {extact database file spec}
793 RegexObj.ModifierG := false; {turn off greedy matches}
794 RegexObj.Expression := '^([a-zA-Z46]+)://([a-zA-Z0-9\-\.]*)(|:[0-9a-zA-Z\-]+)/(.*)$';
795 Result := RegexObj.Exec(ConnectString);
796 if Result then
797 begin
798 {URL type connect string}
799 Protocol := GetProtocol(RegexObj.Match[1]);
800 ServerName := RegexObj.Match[2];
801 if RegexObj.MatchLen[3] > 0 then
802 PortNo := system.Copy(ConnectString,RegexObj.MatchPos[3]+1,RegexObj.MatchLen[3]-1);
803 DatabaseName := RegexObj.Match[4];
804 if ServerName = '' then
805 DatabaseName := '/' + DatabaseName;
806 end
807 else
808 begin
809 {URL type connect string - local loop}
810 RegexObj.Expression := '^([a-zA-Z46]+)://(.*)$';
811 Result := RegexObj.Exec(ConnectString);
812 if Result then
813 begin
814 Protocol := GetProtocol(RegexObj.Match[1]);
815 DatabaseName := RegexObj.Match[2];
816 end
817 else
818 begin
819 RegexObj.Expression := '^([a-zA-Z]:\\.*)';
820 Result := RegexObj.Exec(ConnectString);
821 if Result then
822 Protocol := Local {Windows with leading drive ID}
823 else
824 begin
825 RegexObj.Expression := '^([a-zA-Z0-9\-\.]+)(|/[0-9a-zA-Z\-]+):(.*)$';
826 Result := RegexObj.Exec(ConnectString);
827 if Result then
828 begin
829 {Legacy TCP Format}
830 ServerName := RegexObj.Match[1];
831 if RegexObj.MatchLen[2] > 0 then
832 PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
833 DatabaseName := RegexObj.Match[3];
834 Protocol := TCP;
835 end
836 else
837 begin
838 RegexObj.Expression := '^\\\\([a-zA-Z0-9\-\.]+)(|@[0-9a-zA-Z\-]+)\\(.*)$';
839 Result := RegexObj.Exec(ConnectString);
840 if Result then
841 begin
842 {Netbui}
843 ServerName := RegexObj.Match[1];
844 if RegexObj.MatchLen[2] > 0 then
845 PortNo := system.Copy(ConnectString,RegexObj.MatchPos[2]+1,RegexObj.MatchLen[2]-1);
846 DatabaseName := RegexObj.Match[3];
847 Protocol := NamedPipe
848 end
849 else
850 begin
851 Result := true;
852 Protocol := Local; {Assume local}
853 end;
854 end;
855 end;
856 end;
857 end;
858 finally
859 RegexObj.Free;
860 end;
861 end;
862
863 function GetProtocol(ConnectString: AnsiString): TProtocolAll;
864 var ServerName,
865 DatabaseName: AnsiString;
866 PortNo: AnsiString;
867 begin
868 ParseConnectString(ConnectString,ServerName,DatabaseName,Result,PortNo);
869 end;
870
871 {$ELSE}
872 {cruder version of above for Delphi. Older versions lack regular expression
873 handling.}
874 function ExtractConnectString(const CreateSQL: AnsiString;
875 var ConnectString: AnsiString): boolean;
876 var i: integer;
877 begin
878 Result := false;
879 i := Pos('''',CreateSQL);
880 if i > 0 then
881 begin
882 ConnectString := CreateSQL;
883 delete(ConnectString,1,i);
884 i := Pos('''',ConnectString);
885 if i > 0 then
886 begin
887 delete(ConnectString,i,Length(ConnectString)-i+1);
888 Result := true;
889 end;
890 end;
891 end;
892
893 function GetProtocol(ConnectString: AnsiString): TProtocolAll;
894 begin
895 Result := unknownProtocol; {not implemented for Delphi}
896 end;
897
898 function ParseConnectString(ConnectString: AnsiString;
899 var ServerName, DatabaseName: AnsiString; var Protocol: TProtocolAll;
900 var PortNo: AnsiString): boolean;
901 begin
902 Result := false;
903 end;
904
905 {$ENDIF}
906
907 {Make a connect string in format appropriate protocol}
908
909 function MakeConnectString(ServerName, DatabaseName: AnsiString;
910 Protocol: TProtocol; PortNo: AnsiString): AnsiString;
911
912 function FormatURL: AnsiString;
913 begin
914 if (ServerName = '') and (Pos('/',DatabaseName) <= 1) then
915 Result := DatabaseName
916 else
917 Result := ServerName + '/' + DatabaseName;
918 end;
919
920 begin
921 if PortNo <> '' then
922 case Protocol of
923 NamedPipe:
924 ServerName := ServerName + '@' + PortNo;
925 Local,
926 SPX,
927 xnet: {do nothing};
928 TCP:
929 ServerName := ServerName + '/' + PortNo;
930 else
931 ServerName := ServerName + ':' + PortNo;
932 end;
933
934 case Protocol of
935 TCP: Result := ServerName + ':' + DatabaseName; {do not localize}
936 SPX: Result := ServerName + '@' + DatabaseName; {do not localize}
937 NamedPipe: Result := '\\' + ServerName + '\' + DatabaseName; {do not localize}
938 Local: Result := DatabaseName; {do not localize}
939 inet: Result := 'inet://' + FormatURL; {do not localize}
940 inet4: Result := 'inet4://' + FormatURL; {do not localize}
941 inet6: Result := 'inet6://' + FormatURL; {do not localize}
942 wnet: Result := 'wnet://' + FormatURL; {do not localize}
943 xnet: Result := 'xnet://' + FormatURL; {do not localize}
944 end;
945 end;
946
947 {Format an SQL Identifier according to SQL Dialect with encapsulation if necessary}
948
949 function QuoteIdentifierIfNeeded(Dialect: Integer; Value: AnsiString): AnsiString;
950 begin
951 if (Dialect = 3) and
952 (IsReservedWord(Value) or not IsSQLIdentifier(Value) or (AnsiUpperCase(Value) <> Value)) then
953 Result := '"' + StringReplace (TrimRight(Value), '"', '""', [rfReplaceAll]) + '"'
954 else
955 Result := Value
956 end;
957
958 {Replaces unknown characters in a string with underscores}
959
960 function Space2Underscore(s: AnsiString): AnsiString;
961 var
962 k: integer;
963 begin
964 Result := s;
965 for k := 1 to Length(s) do
966 if not (Result[k] in ValidSQLIdentifierChars) then
967 Result[k] := '_';
968 end;
969
970 {Reformats an SQL string with single quotes duplicated.}
971
972 function SQLSafeString(const s: AnsiString): AnsiString;
973 begin
974 Result := StringReplace(s,'''','''''',[rfReplaceAll]);
975 end;
976
977 { TSQLwithNamedParamsTokeniser }
978
979 procedure TSQLwithNamedParamsTokeniser.Assign(source: TSQLTokeniser);
980 begin
981 inherited Assign(source);
982 if source is TSQLwithNamedParamsTokeniser then
983 begin
984 FState := TSQLwithNamedParamsTokeniser(source).FState;
985 FNested := TSQLwithNamedParamsTokeniser(source).FNested;
986 end;
987 end;
988
989 procedure TSQLwithNamedParamsTokeniser.Reset;
990 begin
991 inherited Reset;
992 FState := stInit;
993 FNested := 0;
994 end;
995
996 function TSQLwithNamedParamsTokeniser.TokenFound(var token: TSQLTokens
997 ): boolean;
998 begin
999 Result := inherited TokenFound(token);
1000 if not Result then Exit;
1001
1002 case FState of
1003 stInit:
1004 begin
1005 case token of
1006 sqltColon:
1007 begin
1008 FState := stInParam;
1009 ResetQueue(token);
1010 end;
1011
1012 sqltBegin:
1013 begin
1014 FState := stInBlock;
1015 FNested := 1;
1016 end;
1017
1018 sqltOpenSquareBracket:
1019 FState := stInArrayDim;
1020
1021 end;
1022 end;
1023
1024 stInParam:
1025 begin
1026 case token of
1027 sqltIdentifier:
1028 token := sqltParam;
1029
1030 sqltIdentifierInDoubleQuotes:
1031 token := sqltQuotedParam;
1032
1033 else
1034 begin
1035 QueueToken(token);
1036 ReleaseQueue(token);
1037 end;
1038 end;
1039 FState := stInit;
1040 end;
1041
1042 stInBlock:
1043 begin
1044 case token of
1045 sqltBegin:
1046 Inc(FNested);
1047
1048 sqltEnd:
1049 begin
1050 Dec(FNested);
1051 if FNested = 0 then
1052 FState := stInit;
1053 end;
1054 end;
1055 end;
1056
1057 stInArrayDim:
1058 begin
1059 if token = sqltCloseSquareBracket then
1060 FState := stInit;
1061 end;
1062 end;
1063
1064 Result := (FState <> stInParam);
1065 end;
1066
1067 { TSQLTokeniser }
1068
1069 function TSQLTokeniser.GetNext: TSQLTokens;
1070 var C: AnsiChar;
1071 begin
1072 if EOF then
1073 Result := sqltEOF
1074 else
1075 begin
1076 C := GetChar;
1077 case C of
1078 #0:
1079 Result := sqltEOF;
1080 ' ',TAB:
1081 Result := sqltSpace;
1082 '0'..'9':
1083 Result := sqltNumberString;
1084 ';':
1085 Result := sqltSemiColon;
1086 '?':
1087 Result := sqltPlaceholder;
1088 '|':
1089 Result := sqltPipe;
1090 '"':
1091 Result := sqltDoubleQuotes;
1092 '''':
1093 Result := sqltSingleQuotes;
1094 '/':
1095 Result := sqltForwardSlash;
1096 '*':
1097 Result := sqltAsterisk;
1098 '(':
1099 Result := sqltOpenBracket;
1100 ')':
1101 Result := sqltCloseBracket;
1102 ':':
1103 Result := sqltColon;
1104 ',':
1105 Result := sqltComma;
1106 '.':
1107 Result := sqltPeriod;
1108 '=':
1109 Result := sqltEquals;
1110 '[':
1111 Result := sqltOpenSquareBracket;
1112 ']':
1113 Result := sqltCloseSquareBracket;
1114 '<':
1115 Result := sqltLT;
1116 '>':
1117 Result := sqltGT;
1118 CR:
1119 Result := sqltCR;
1120 LF:
1121 Result := sqltEOL;
1122 else
1123 if C in ValidSQLIdentifierChars then
1124 Result := sqltIdentifier
1125 else
1126 Result := sqltOtherCharacter;
1127 end;
1128 FLastChar := C
1129 end;
1130 FNextToken := Result;
1131 end;
1132
1133 procedure TSQLTokeniser.PopQueue(var token: TSQLTokens);
1134 begin
1135 if FQFirst = FQLast then
1136 IBError(ibxeTokenQueueUnderflow,[]);
1137 token := FTokenQueue[FQFirst].token;
1138 FString := FTokenQueue[FQFirst].text;
1139 Inc(FQFirst);
1140 if FQFirst = FQLast then
1141 FQueueState := tsHold;
1142 end;
1143
1144 procedure TSQLTokeniser.Assign(source: TSQLTokeniser);
1145 begin
1146 FString := source.FString;
1147 FNextToken := source.FNextToken;
1148 FTokenQueue := source.FTokenQueue;
1149 FQueueState := source.FQueueState;
1150 FQFirst := source.FQFirst;
1151 FQLast := source.FQLast;
1152 end;
1153
1154 function TSQLTokeniser.TokenFound(var token: TSQLTokens): boolean;
1155 begin
1156 Result := (FState = stDefault);
1157 if Result and (token = sqltIdentifier) then
1158 FindReservedWord(FString,token);
1159 end;
1160
1161 procedure TSQLTokeniser.QueueToken(token: TSQLTokens; text: AnsiString);
1162 begin
1163 if FQLast > TokenQueueMaxSize then
1164 IBError(ibxeTokenQueueOverflow,[]);
1165 FTokenQueue[FQLast].token := token;
1166 FTokenQueue[FQLast].text := text;
1167 Inc(FQLast);
1168 end;
1169
1170 procedure TSQLTokeniser.QueueToken(token: TSQLTokens);
1171 begin
1172 QueueToken(token,TokenText);
1173 end;
1174
1175 procedure TSQLTokeniser.ResetQueue;
1176 begin
1177 FQFirst := 0;
1178 FQLast := 0;
1179 FQueueState := tsHold;
1180 end;
1181
1182 procedure TSQLTokeniser.ResetQueue(token: TSQLTokens; text: AnsiString);
1183 begin
1184 ResetQueue;
1185 QueueToken(token,text);
1186 end;
1187
1188 procedure TSQLTokeniser.ResetQueue(token: TSQLTokens);
1189 begin
1190 ResetQueue;
1191 QueueToken(token);
1192 end;
1193
1194 procedure TSQLTokeniser.ReleaseQueue(var token: TSQLTokens);
1195 begin
1196 FQueueState := tsRelease;
1197 PopQueue(token);
1198 end;
1199
1200 procedure TSQLTokeniser.ReleaseQueue;
1201 begin
1202 FQueueState := tsRelease;
1203 end;
1204
1205 function TSQLTokeniser.GetQueuedText: AnsiString;
1206 var i: integer;
1207 begin
1208 Result := '';
1209 for i := FQFirst to FQLast do
1210 Result := Result + FTokenQueue[i].text;
1211 end;
1212
1213 procedure TSQLTokeniser.SetTokenText(text: AnsiString);
1214 begin
1215 FString := text;
1216 end;
1217
1218 constructor TSQLTokeniser.Create;
1219 begin
1220 inherited Create;
1221 Reset;
1222 end;
1223
1224 destructor TSQLTokeniser.Destroy;
1225 begin
1226 Reset;
1227 inherited Destroy;
1228 end;
1229
1230 procedure TSQLTokeniser.Reset;
1231 begin
1232 FNextToken := sqltInit;
1233 FState := stDefault;
1234 FString := '';
1235 FEOF := false;
1236 ResetQueue;
1237 end;
1238
1239 function TSQLTokeniser.GetNextToken: TSQLTokens;
1240 begin
1241 if FQueueState = tsRelease then
1242 repeat
1243 PopQueue(Result);
1244 FEOF := Result = sqltEOF;
1245 if TokenFound(Result) then
1246 Exit;
1247 until FQueueState <> tsRelease;
1248
1249 Result := InternalGetNextToken;
1250 end;
1251
1252 {a simple lookahead one algorithm to extra the next symbol}
1253
1254 function TSQLTokeniser.InternalGetNextToken: TSQLTokens;
1255 var C: AnsiChar;
1256 begin
1257 Result := sqltEOF;
1258
1259 if FNextToken = sqltInit then
1260 GetNext;
1261
1262 repeat
1263 Result := FNextToken;
1264 C := FLastChar;
1265 GetNext;
1266
1267 if FSkipNext then
1268 begin
1269 FSkipNext := false;
1270 continue;
1271 end;
1272
1273 case FState of
1274 stInComment:
1275 begin
1276 if (Result = sqltAsterisk) and (FNextToken = sqltForwardSlash) then
1277 begin
1278 FState := stDefault;
1279 Result := sqltComment;
1280 GetNext;
1281 end
1282 else
1283 FString := FString + C;
1284 end;
1285
1286 stInCommentLine:
1287 begin
1288 case Result of
1289 sqltEOL:
1290 begin
1291 FState := stDefault;
1292 Result := sqltCommentLine;
1293 end;
1294
1295 sqltCR: {ignore};
1296
1297 else
1298 FString := FString + C;
1299 end;
1300 end;
1301
1302 stSingleQuoted:
1303 begin
1304 if (Result = sqltSingleQuotes) then
1305 begin
1306 if (FNextToken = sqltSingleQuotes) then
1307 begin
1308 FSkipNext := true;
1309 FString := FString + C;
1310 end
1311 else
1312 begin
1313 Result := sqltQuotedString;
1314 FState := stDefault;
1315 end;
1316 end
1317 else
1318 FString := FString + C;
1319 end;
1320
1321 stDoubleQuoted:
1322 begin
1323 if (Result = sqltDoubleQuotes) then
1324 begin
1325 if (FNextToken = sqltDoubleQuotes) then
1326 begin
1327 FSkipNext := true;
1328 FString := FString + C;
1329 end
1330 else
1331 begin
1332 Result := sqltIdentifierInDoubleQuotes;
1333 FState := stDefault;
1334 end;
1335 end
1336 else
1337 FString := FString + C;
1338 end;
1339
1340 stInIdentifier:
1341 begin
1342 FString := FString + C;
1343 Result := sqltIdentifier;
1344 if not (FNextToken in [sqltIdentifier,sqltNumberString]) then
1345 FState := stDefault
1346 end;
1347
1348 stInNumeric:
1349 begin
1350 FString := FString + C;
1351 if (Result = sqltPeriod) and (FNextToken = sqltPeriod) then
1352 begin
1353 {malformed decimal}
1354 FState := stInIdentifier;
1355 Result := sqltIdentifier
1356 end
1357 else
1358 begin
1359 if not (FNextToken in [sqltNumberString,sqltPeriod]) then
1360 FState := stDefault;
1361 Result := sqltNumberString;
1362 end;
1363 end;
1364
1365 else {stDefault}
1366 begin
1367 FString := C;
1368 case Result of
1369
1370 sqltPipe:
1371 if FNextToken = sqltPipe then
1372 begin
1373 Result := sqltConcatSymbol;
1374 FString := C + FLastChar;
1375 GetNext;
1376 end;
1377
1378 sqltForwardSlash:
1379 begin
1380 if FNextToken = sqltAsterisk then
1381 begin
1382 FString := '';
1383 GetNext;
1384 FState := stInComment;
1385 end
1386 else
1387 if FNextToken = sqltForwardSlash then
1388 begin
1389 FString := '';
1390 GetNext;
1391 FState := stInCommentLine;
1392 end;
1393 end;
1394
1395 sqltSingleQuotes:
1396 begin
1397 FString := '';
1398 FState := stSingleQuoted;
1399 end;
1400
1401 sqltDoubleQuotes:
1402 begin
1403 FString := '';
1404 FState := stDoubleQuoted;
1405 end;
1406
1407 sqltIdentifier:
1408 if FNextToken = sqltIdentifier then
1409 FState := stInIdentifier;
1410
1411 sqltNumberString:
1412 if FNextToken in [sqltNumberString,sqltPeriod] then
1413 FState := stInNumeric;
1414 end;
1415 end;
1416 end;
1417
1418 // writeln(FString);
1419 FEOF := Result = sqltEOF;
1420 until TokenFound(Result) or EOF;
1421 end;
1422
1423 end.