sql parser: support CASE expression

git-svn-id: trunk@46428 -

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

@@ -77,6 +77,7 @@ Type
     function ParseExprLevel5(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression;
     function ParseExprLevel6(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression;
     function ParseExprPrimitive(AParent: TSQLElement; EO : TExpressionOptions): TSQLExpression;
+    function ParseCaseExpression(AParent: TSQLElement): TSQLCaseExpression;
     function ParseInoperand(AParent: TSQLElement): TSQLExpression;
     // Lists, primitives
     function ParseIdentifierList(AParent: TSQLElement; AList: TSQLelementList): integer;
@@ -1331,6 +1332,34 @@ begin
 end;
 
 
+function TSQLParser.ParseCaseExpression(AParent: TSQLElement): TSQLCaseExpression;
+var
+  Branch: TSQLCaseExpressionBranch;
+begin
+  Consume(tsqlCASE);
+  Result:=TSQLCaseExpression(CreateElement(TSQLCaseExpression,AParent));
+  try
+    while CurrentToken=tsqlWhen do
+      begin
+      GetNextToken;
+      Branch := TSQLCaseExpressionBranch.Create;
+      Branch.Condition:=ParseExprLevel1(AParent,[eoIF]);
+      Consume(tsqlThen);
+      Branch.Expression:=ParseExprLevel1(AParent,[eoIF]);
+      Result.AddBranch(Branch);
+      end;
+    if CurrentToken=tsqlELSE then
+      begin
+      GetNextToken;
+      Result.ElseBranch:=ParseExprLevel1(AParent,[eoIF]);
+      end;
+    Consume(tsqlEnd);
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
 procedure TSQLParser.ParseIntoList(AParent : TSQLElement; List : TSQLElementList);
 
 begin
@@ -2733,6 +2762,7 @@ begin
         TSQLCastExpression(Result).NewType:=ParseTypeDefinition(Result,[ptfCast]);
         Consume(tsqlBraceClose);
         end;
+      tsqlCase: Result:=ParseCaseExpression(AParent);
       tsqlExtract:
         begin
         GetNextToken;

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

@@ -51,7 +51,7 @@ type
    { 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, tsqlBinary, tsqlBY, tsqlBLOB, tsqlBegin, tsqlBefore,
-   tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString,
+   tsqlCASE, tsqlCOLLATE, tsqlCONTAINING, tsqlCOUNT, tsqlCREATE, tsqlCOLUMN, tsqlCONSTRAINT, tsqlChar,tsqlCHARACTER, tsqlCHECK, tsqlComputed,tsqlCASCADE, tsqlCast, tsqlCommit,tsqlConnect,tsqlCache,tsqlConditional,tsqlCString,
    tsqlDESC, tsqlDESCENDING, tsqlDISTINCT, tsqlDEFAULT, tsqlDELETE, tsqlDO, tsqlDouble, tsqlDECLARE, tsqlDROP, tsqlDomain, tsqlDecimal, tsqlDate,tsqlDatabase,
    tsqlESCAPE, tsqlEXISTS, tsqlELSE, tsqlException,   tsqlExternal, tsqlExecute, tsqlEnd,tsqlExit,tsqlEntrypoint,tsqlExtract,
    tsqlFIRST, tsqlFROM, tsqlFULL, tsqlFOREIGN, tsqlFOR, tsqlFUNCTION, tsqlFLOAT, tsqlFile,tsqlFreeIt,
@@ -97,7 +97,7 @@ const
        // Identifiers last:
        'ALL', 'AND', 'ANY', 'ASC', 'ASCENDING', 'AVG', 'ALTER', 'ADD','ACTIVE','ACTION', 'AS', 'AT', 'AUTO', 'AFTER', 'ADMIN',
        'BETWEEN', 'BINARY', 'BY', 'BLOB','BEGIN', 'BEFORE',
-       'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING',
+       'CASE', 'COLLATE', 'CONTAINING', 'COUNT', 'CREATE', 'COLUMN', 'CONSTRAINT', 'CHAR','CHARACTER','CHECK', 'COMPUTED','CASCADE','CAST', 'COMMIT', 'CONNECT', 'CACHE','CONDITIONAL', 'CSTRING',
        'DESC', 'DESCENDING', 'DISTINCT',  'DEFAULT', 'DELETE', 'DO', 'DOUBLE', 'DECLARE', 'DROP', 'DOMAIN', 'DECIMAL', 'DATE','DATABASE',
        'ESCAPE', 'EXISTS', 'ELSE', 'EXCEPTION', 'EXTERNAL','EXECUTE', 'END','EXIT','ENTRY_POINT','EXTRACT',
        'FIRST', 'FROM', 'FULL','FOREIGN', 'FOR', 'FUNCTION', 'FLOAT','FILE', 'FREE_IT',

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

@@ -1411,6 +1411,38 @@ Type
     Property FalseBranch : TSQLStatement Read FFalseBranch Write FFalseBranch;
   end;
 
+  { TSQLCaseExpressionBranch }
+
+  TSQLCaseExpressionBranch = Class
+  private
+    FCondition: TSQLExpression;
+    FExpression: TSQLExpression;
+  public
+    destructor Destroy; override;
+  public
+    property Condition: TSQLExpression read FCondition write FCondition;
+    property Expression: TSQLExpression read FExpression write FExpression;
+  end;
+
+  { TSQLCaseExpression }
+
+  TSQLCaseExpression = Class(TSQLExpression)
+  private
+    FBranches: array of TSQLCaseExpressionBranch;
+    FElseBranch: TSQLExpression;
+    function GetBranch(Index: Integer): TSQLCaseExpressionBranch;
+    function GetBranchCount: Integer;
+  Public
+    Destructor Destroy; override;
+    Function GetAsSQL(Options : TSQLFormatOptions; AIndent : Integer = 0): TSQLStringType; override;
+
+    Property BranchCount: Integer Read GetBranchCount;
+    Procedure AddBranch(ABranch: TSQLCaseExpressionBranch);
+    Procedure ClearBranches;
+    Property Branches[Index: Integer] : TSQLCaseExpressionBranch Read GetBranch;
+    Property ElseBranch : TSQLExpression Read FElseBranch Write FElseBranch;
+  end;
+
   { TSQLForStatement }
 
   TSQLForStatement = Class(TSQLStatement)
@@ -1937,6 +1969,63 @@ begin
     Sep:=', ';
 end;
 
+{ TSQLCaseExpressionBranch }
+
+destructor TSQLCaseExpressionBranch.Destroy;
+begin
+  FreeAndNil(FCondition);
+  FreeAndNil(FExpression);
+  inherited Destroy;
+end;
+
+{ TSQLCaseExpression }
+
+procedure TSQLCaseExpression.AddBranch(ABranch: TSQLCaseExpressionBranch);
+begin
+  SetLength(FBranches, Length(FBranches)+1);
+  FBranches[High(FBranches)] := ABranch;
+end;
+
+procedure TSQLCaseExpression.ClearBranches;
+var
+  B: TSQLCaseExpressionBranch;
+begin
+  for B in FBranches do
+    B.Free;
+  FBranches:=nil;
+end;
+
+destructor TSQLCaseExpression.Destroy;
+begin
+  ClearBranches;
+  FreeAndNil(FElseBranch);
+  inherited Destroy;
+end;
+
+function TSQLCaseExpression.GetAsSQL(Options: TSQLFormatOptions; AIndent: Integer): TSQLStringType;
+var
+  B: TSQLCaseExpressionBranch;
+begin
+  Result:=SQLKeyWord('CASE',Options)+' ';
+  for B in FBranches do
+    Result:=Result+
+      SQLKeyWord('WHEN ',Options)+B.Condition.GetAsSQL(Options, AIndent)+' '+
+      SQLKeyWord('THEN ',Options)+B.Expression.GetAsSQL(Options, AIndent)+' ';
+  If Assigned(FElseBranch) then
+    Result:=Result+SQLKeyWord('ELSE ',Options)+ElseBranch.GetAsSQL(Options,AIndent)+' ';
+  Result:=Result+SQLKeyWord('END',Options);
+end;
+
+function TSQLCaseExpression.GetBranch(Index: Integer): TSQLCaseExpressionBranch;
+begin
+  Result := FBranches[Index];
+end;
+
+function TSQLCaseExpression.GetBranchCount: Integer;
+begin
+  Result := Length(FBranches);
+end;
+
 { TSQLSelectLimit }
 
 constructor TSQLSelectLimit.Create;

packages/fcl-db/tests/tcgensql.pas

@@ -69,6 +69,7 @@ type
     Procedure TestSimpleSelect;
     Procedure TestAnyExpression;
     procedure TestAllExpression;
+    procedure TestCaseExpression;
     procedure TestExistsExpression;
     procedure TestSomeExpression;
     procedure TestSingularExpression;
@@ -816,7 +817,7 @@ begin
   AssertSQL(U,'constraint C unique (A , B)',[sfoLowercaseKeyWord]);
 end;
 
-procedure TTestGenerateSQL.TestTableprimaryKeyConstraintDef;
+procedure TTestGenerateSQL.TestTablePrimaryKeyConstraintDef;
 
 Var
   U : TSQLTablePrimaryKeyConstraintDef;
@@ -1872,6 +1873,35 @@ begin
   AssertSQL(B,'BEGIN'+sLineBreak+'  BEGIN'+sLineBreak+'    EXIT;'+sLineBreak+'  END'+sLineBreak+'END');
 end;
 
+procedure TTestGenerateSQL.TestCaseExpression;
+
+Var
+  E : TSQLCaseExpression;
+  B : TSQLCaseExpressionBranch;
+  C : TSQLBinaryExpression;
+
+begin
+  E:=TSQLCaseExpression.Create(Nil);
+
+  B:=TSQLCaseExpressionBranch.Create;
+  C:=CreateBinaryExpression(CreateIdentifierExpression('A'),CreateIdentifierExpression('B'));
+  C.Operation:=boEQ;
+  B.Condition:=C;
+  B.Expression:=CreateLiteralExpression(CreateLiteral(1));
+  E.AddBranch(B);
+
+  B:=TSQLCaseExpressionBranch.Create;
+  C:=CreateBinaryExpression(CreateIdentifierExpression('A'),CreateIdentifierExpression('B'));
+  C.Operation:=boGT;
+  B.Condition:=C;
+  B.Expression:=CreateLiteralExpression(CreateLiteral(2));
+  E.AddBranch(B);
+
+  E.ElseBranch:=CreateLiteralExpression(CreateLiteral(3));
+  FTofree:=E;
+  AssertSQL(E,'CASE WHEN A = B THEN 1 WHEN A > B THEN 2 ELSE 3 END');
+end;
+
 procedure TTestGenerateSQL.TestAssignment;
 
 var

packages/fcl-db/tests/tcparser.pas

@@ -230,6 +230,7 @@ type
     procedure TestAnd;
     procedure TestOr;
     procedure TestNotOr;
+    procedure TestCase;
   end;
 
   { TTestDomainParser }
@@ -2203,6 +2204,34 @@ begin
   AssertLiteralExpr('Right is integer',T.Right,TSQLIntegerLiteral);
 end;
 
+procedure TTestCheckParser.TestCase;
+
+Var
+  T : TSQLCaseExpression;
+  B : TSQLBinaryExpression;
+  R : TSQLIdentifierName;
+
+begin
+  T:=TSQLCaseExpression(TestCheck('CASE WHEN A=1 THEN "a" WHEN B=2 THEN "b" ELSE "c" END',TSQLCaseExpression));
+  AssertEquals('Branch count = 2',2,T.BranchCount);
+  AssertNotNull('Else branch exists',T.ElseBranch);
+
+  B:=(T.Branches[0].Condition as TSQLBinaryExpression);
+  R:=(T.Branches[0].Expression as TSQLIdentifierExpression).Identifier;
+  AssertEquals('First WHEN Identifier is A', 'A', (B.Left as TSQLIdentifierExpression).Identifier.Name);
+  AssertEquals('First WHEN Number is 1', 1, ((B.Right as TSQLLiteralExpression).Literal as TSQLIntegerLiteral).Value);
+  AssertEquals('First THEN result is "a"', 'a', R.Name);
+
+  B:=(T.Branches[1].Condition as TSQLBinaryExpression);
+  R:=(T.Branches[1].Expression as TSQLIdentifierExpression).Identifier;
+  AssertEquals('Second WHEN Identifier is B', 'B', (B.Left as TSQLIdentifierExpression).Identifier.Name);
+  AssertEquals('Second WHEN Number is 2', 2, ((B.Right as TSQLLiteralExpression).Literal as TSQLIntegerLiteral).Value);
+  AssertEquals('Second THEN result is "b"', 'b', R.Name);
+
+  R:=(T.ElseBranch as TSQLIdentifierExpression).Identifier;
+  AssertEquals('ELSE result is "c"', 'c', R.Name);
+end;
+
 procedure TTestCheckParser.TestNotBetween;
 
 Var