* fcl-db: sql parser: Allow:

- double precision datatype
- blob subtype text and blob subtype binary (instead of only blob subtype 0 and 1)
- Associated tests

git-svn-id: trunk@27887 -

packages/fcl-db/src/sql/fpsqlparser.pas

@@ -49,19 +49,20 @@ Type
     FPeekTokenString: String;
     Procedure CheckEOF;
   protected
-    Procedure UnexpectedToken; overload;
+    procedure UnexpectedToken; overload;
-    Procedure UnexpectedToken(AExpected : TSQLTokens); overload;
+    procedure UnexpectedToken(AExpected : TSQLTokens); overload;
     // All elements must be created with this factory function
-    Function CreateElement(AElementClass : TSQLElementClass; APArent : TSQLElement)  : TSQLElement; virtual;
+    function CreateElement(AElementClass : TSQLElementClass; APArent : TSQLElement)  : TSQLElement; virtual;
     function CreateLiteral(AParent: TSQLElement): TSQLLiteral;
-    Function CreateIdentifier(AParent : TSQLElement; Const AName : TSQLStringType) : TSQLIdentifierName;
+    function CreateIdentifier(AParent : TSQLElement; Const AName : TSQLStringType) : TSQLIdentifierName;
-    // Verify that current token is the expect token; raise error if not
+    // Verify that current token is the expected token; raise error if not
     procedure Expect(aToken: TSQLToken);
+    // Verify that current token is one of the expected tokens; raise error if not
     procedure Expect(aTokens: TSQLTokens);
-    // Expects aToken and eats it
+    // Expects aToken as current token and eats it
     procedure Consume(aToken: TSQLToken);
     procedure Error(Msg : String);
-    Procedure Error(Fmt : String; Args : Array of const);
+    procedure Error(Fmt : String; Args : Array of const);
     // Expression support
     function ParseExprLevel1(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression;
     function ParseExprLevel2(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression;
@@ -195,7 +196,7 @@ Resourcestring
   SErrUnexpectedTokenOf = 'Unexpected token: %s, expected one of %s';
   SErrTokenMismatch   = 'Unexpected token: ''%s'', expected: ''%s''';
   SErrExpectedDBObject = 'Expected database object type. Got: ''%s''';
-  SErrDomainNotAllowed = 'Domain name not allowed in typ definition.';
+  SErrDomainNotAllowed = 'Domain name not allowed in type definition.';
   SErrExpectedChar = 'Expected CHAR or CHARACTER, got "%s"';
   SERRVaryingNotAllowed = 'VARYING not allowed at this point.';
   SErrUnknownBooleanOp = 'Unknown boolean operation';
@@ -804,7 +805,7 @@ begin
       Result.ComputedBy:=ParseExprLevel1(Result,[eoComputedBy]);
       Consume(tsqlBraceClose);
       end
-    else
+    else //not computed, regular field
       Result.FieldType:=ParseTypeDefinition(Result,[ptfAllowDomainName,ptfAllowConstraint,ptfTableFieldDef]);
   except
     FreeAndNil(Result);
@@ -1618,8 +1619,13 @@ begin
     If CurrentToken=tsqlSubtype then   // SUB_TYPE T
       begin
       GetNextToken;
-      Expect(tsqlIntegerNumber);
+      Expect([tsqlIntegerNumber,tsqlBinary,tsqlText]);
-      ABlobType:=StrtoInt(CurrentTokenString);
+      case CurrentToken of
+        tsqlBinary: ABlobType:=0; //FB2.0+ see Language Reference Update
+        tsqlText: ABlobType:=1;
+        tsqlIntegerNumber: ABlobType:=StrtoInt(CurrentTokenString);
+        else Error('ParseBlobDefinition: internal error: unknown token type.');
+      end;
       GetNextToken;
       end;
     If (CurrentToken=tsqlSegment) then // SEGMENT SIZE S
@@ -1837,6 +1843,12 @@ begin
        dt:=sdtDate;
      tsqlTimeStamp:
        dt:=sdtDateTime;
+     tsqlDouble:
+       begin
+       GetNextToken;
+       Consume(tsqlPrecision); //DOUBLE PRECISION
+       dt:=sdtDoublePrecision;
+       end;
      tsqlFloat:
        dt:=sdtFloat;
      tsqlTime:

packages/fcl-db/src/sql/fpsqlscanner.pp

@@ -42,11 +42,12 @@ type
    tsqlPlaceHolder,tsqlCOMMA,tsqlCOLON,tsqlDOT,tsqlSEMICOLON,tsqlGT,tsqlLT,
    tsqlPLUS,tsqlMINUS,tsqlMUL,tsqlDIV,tsqlConcatenate,
    tsqlEQ,tsqlGE,tsqlLE,tsqlNE,
-   { Reserved words start here. They must be last }
+   { Reserved words/keywords start here. They must be last }
+   { Note: if adding before tsqlALL or after tsqlWHEN please update FirstKeyword/LastKeyword }
    tsqlALL, tsqlAND, tsqlANY, tsqlASC, tsqlASCENDING, tsqlAVG, tsqlALTER, tsqlAdd, tsqlActive, tsqlAction, tsqlAs,tsqlAt, tsqlAuto,tsqlAfter,tsqlAdmin,
-   tsqlBETWEEN, tsqlBY, tsqlBLOB,tsqlBegin,  tsqlBefore,
+   tsqlBETWEEN, tsqlBinary, tsqlBY, tsqlBLOB, tsqlBegin, tsqlBefore,
    tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString,
-   tsqlDESC, tsqlDESCENDING, tsqlDISTINCT, tsqlDEFAULT, tsqlDELETE, tsqlDO, tsqlDECLARE, tsqlDROP, tsqlDomain, tsqlDecimal, tsqlDate,tsqlDatabase,
+   tsqlDESC, tsqlDESCENDING, tsqlDISTINCT, tsqlDEFAULT, tsqlDELETE, tsqlDO, tsqlDouble, tsqlDECLARE, tsqlDROP, tsqlDomain, tsqlDecimal, tsqlDate,tsqlDatabase,
    tsqlESCAPE, tsqlEXISTS, tsqlELSE, tsqlException,   tsqlExternal, tsqlExecute, tsqlEnd,tsqlExit,tsqlEntrypoint,tsqlExtract,
    tsqlFROM, tsqlFULL, tsqlFOREIGN, tsqlFOR, tsqlFUNCTION, tsqlFLOAT, tsqlFile,tsqlFreeIt,
    tsqlGenerator, tsqlGROUP, tsqlGenID,tsqlGDSCODE,tsqlGrant,
@@ -58,10 +59,10 @@ type
    tsqlMAX, tsqlMIN, tsqlMERGE, tsqlManual, tsqlModuleName,
    tsqlNOT, tsqlNULL, tsqlNUMERIC , tsqlNChar, tsqlNATIONAL,tsqlNO, tsqlNatural,
    tsqlON, tsqlOR, tsqlORDER, tsqlOUTER, tsqlOption,
-   tsqlPRIMARY,  tsqlProcedure, tsqlPosition, tsqlPlan, tsqlPassword, tsqlPage,tsqlPages,tsqlPageSize,tsqlPostEvent,tsqlPrivileges,tsqlPublic,
+   tsqlPrecision, tsqlPRIMARY,  tsqlProcedure, tsqlPosition, tsqlPlan, tsqlPassword, tsqlPage,tsqlPages,tsqlPageSize,tsqlPostEvent,tsqlPrivileges,tsqlPublic,
    tsqlRIGHT, tsqlROLE, tsqlReferences, tsqlRollBack, tsqlRelease,  tsqlretain,  tsqlReturningValues,tsqlReturns, tsqlrevoke,
    tsqlSELECT, tsqlSET, tsqlSINGULAR, tsqlSOME, tsqlSTARTING, tsqlSUM, tsqlSKIP,tsqlSUBTYPE,tsqlSize,tsqlSegment, tsqlSORT, tsqlSnapShot,tsqlSchema,tsqlShadow,tsqlSuspend,tsqlSQLCode,tsqlSmallint,
-   tSQLTABLE, tsqlTrigger,tsqlTime,tsqlTimeStamp,tsqlType, tsqlTo, tsqlTransaction,tsqlThen,
+   tSQLTABLE, tsqlText, tsqlTrigger, tsqlTime, tsqlTimeStamp, tsqlType, tsqlTo, tsqlTransaction, tsqlThen,
    tsqlUNION, tsqlUPDATE, tsqlUPPER,  tsqlUNIQUE, tsqlUSER,
    tsqlValue, tsqlVALUES, tsqlVARIABLE,  tsqlVIEW, tsqlVARCHAR,TSQLVARYING,
    tsqlWHERE, tsqlWITH, tsqlWHILE, tsqlWork, tsqlWhen
@@ -83,11 +84,11 @@ const
        '?',',',':','.',';','>','<',
        '+','-','*','/','||',
        '=','>=','<=','<>',
-       // Identifiers last
+       // Identifiers last:
        'ALL', 'AND', 'ANY', 'ASC', 'ASCENDING', 'AVG', 'ALTER', 'ADD','ACTIVE','ACTION', 'AS', 'AT', 'AUTO', 'AFTER', 'ADMIN',
-       'BETWEEN', 'BY', 'BLOB','BEGIN', 'BEFORE',
+       'BETWEEN', 'BINARY', 'BY', 'BLOB','BEGIN', 'BEFORE',
        'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING',
-       'DESC', 'DESCENDING', 'DISTINCT',  'DEFAULT', 'DELETE', 'DO', 'DECLARE', 'DROP', 'DOMAIN', 'DECIMAL', 'DATE','DATABASE',
+       'DESC', 'DESCENDING', 'DISTINCT',  'DEFAULT', 'DELETE', 'DO', 'DOUBLE', 'DECLARE', 'DROP', 'DOMAIN', 'DECIMAL', 'DATE','DATABASE',
        'ESCAPE', 'EXISTS', 'ELSE', 'EXCEPTION', 'EXTERNAL','EXECUTE', 'END','EXIT','ENTRY_POINT','EXTRACT',
        'FROM', 'FULL','FOREIGN', 'FOR', 'FUNCTION', 'FLOAT','FILE', 'FREE_IT',
        'GENERATOR', 'GROUP', 'GEN_ID','GDSCODE','GRANT',
@@ -99,10 +100,10 @@ const
        'MAX', 'MIN', 'MERGE', 'MANUAL', 'MODULE_NAME',
        'NOT', 'NULL', 'NUMERIC','NCHAR','NATIONAL', 'NO', 'NATURAL',
        'ON', 'OR', 'ORDER', 'OUTER', 'OPTION',
-       'PRIMARY', 'PROCEDURE','POSITION','PLAN', 'PASSWORD','PAGE','PAGES','PAGE_SIZE','POST_EVENT','PRIVILEGES','PUBLIC',
+       'PRECISION', 'PRIMARY', 'PROCEDURE','POSITION','PLAN', 'PASSWORD','PAGE','PAGES','PAGE_SIZE','POST_EVENT','PRIVILEGES','PUBLIC',
        'RIGHT', 'ROLE', 'REFERENCES', 'ROLLBACK','RELEASE', 'RETAIN', 'RETURNING_VALUES', 'RETURNS','REVOKE',
        'SELECT', 'SET', 'SINGULAR', 'SOME', 'STARTING', 'SUM', 'SKIP','SUB_TYPE', 'SIZE', 'SEGMENT', 'SORT', 'SNAPSHOT','SCHEMA','SHADOW','SUSPEND','SQLCODE','SMALLINT',
-       'TABLE','TRIGGER',  'TIME','TIMESTAMP',  'TYPE', 'TO', 'TRANSACTION','THEN',
+       'TABLE', 'TEXT', 'TRIGGER', 'TIME', 'TIMESTAMP', 'TYPE', 'TO', 'TRANSACTION', 'THEN',
        'UNION', 'UPDATE', 'UPPER', 'UNIQUE', 'USER',
        'VALUE','VALUES','VARIABLE', 'VIEW','VARCHAR','VARYING',
        'WHERE', 'WITH', 'WHILE','WORK','WHEN'
@@ -637,7 +638,7 @@ begin
     BuildKeyWords;
   P:=FKeyWords.Find(S);
   If (P<>Nil) then
-    Result:=P^;
+    Result:=P^; //keyword found
   { I:=FirstKeyword;
   While (Result=tsqlIdentifier) and (I<=Lastkeyword) do
     begin

packages/fcl-db/tests/tcparser.pas

@@ -166,6 +166,8 @@ type
     procedure TestBlob4;
     procedure TestBlob5;
     procedure TestBlob6;
+    procedure TestBlob7;
+    procedure TestBlob8;
     procedure TestBlobError1;
     procedure TestBlobError2;
     procedure TestBlobError3;
@@ -175,6 +177,7 @@ type
     procedure TestBlobError7;
     procedure TestSmallInt;
     procedure TestFloat;
+    procedure TestDoublePrecision;
   end;
 
   { TTestCheckParser }
@@ -1746,6 +1749,29 @@ begin
   AssertEquals('Blob segment size',0,TD.Len);
   AssertEquals('Character set','',TD.Charset);
 end;
+
+procedure TTestTypeParser.TestBlob7;
+var
+  TD : TSQLTypeDefinition;
+
+begin
+  TD:=TestType('BLOB SUB_TYPE BINARY',[],sdtBlob);
+  AssertEquals('Blob type 0',0,TD.BlobType);
+  AssertEquals('Blob segment size',0,TD.Len);
+  AssertEquals('Character set','',TD.Charset);
+end;
+
+procedure TTestTypeParser.TestBlob8;
+var
+  TD : TSQLTypeDefinition;
+
+begin
+  TD:=TestType('BLOB SUB_TYPE TEXT',[],sdtBlob);
+  AssertEquals('Blob type 1',1,TD.BlobType);
+  AssertEquals('Blob segment size',0,TD.Len);
+  AssertEquals('Character set','',TD.Charset);
+end;
+
 procedure TTestTypeParser.TestSmallInt;
 
 Var
@@ -1761,6 +1787,13 @@ begin
   TD:=TestType('FLOAT',[],sdtFloat);
 end;
 
+procedure TTestTypeParser.TestDoublePrecision;
+var
+  TD : TSQLTypeDefinition;
+begin
+  TD:=TestType('DOUBLE PRECISION',[],sdtDoublePrecision);
+end;
+
 procedure TTestTypeParser.TestBlobError1;
 begin
   FerrSource:='BLOB (1,)';

packages/fcl-db/tests/tcsqlscanner.pas

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Component Library
-    Copyright (c) 2010 by the Free Pascal development team
+    Copyright (c) 2010-2014 by the Free Pascal development team
 
     SQL source lexical scanner test suite
 
@@ -291,7 +291,7 @@ Var
 begin
   CreateScanner(ASource);
   J:=Scanner.FetchToken;
-  EN2:=GetEnumName(TypeINfo(TSQLToken),Ord(AToken));
+  EN2:=GetEnumName(TypeInfo(TSQLToken),Ord(AToken));
   AssertEquals(Format('Source %s should result in %s.',[ASource,EN2]),AToken,J);
 end;