* Implement DollarString extension for Postgres PL/SQL.

git-svn-id: trunk@33241 -

packages/fcl-db/src/base/sqlscript.pp

@@ -19,7 +19,10 @@ unit sqlscript;
 interface
 
 uses
-  Classes, SysUtils; 
+  Classes, SysUtils;
+
+Const
+  MinSQLSeps = 5; // Default, minimum number of standard SQL separators.
 
 type
 
@@ -33,6 +36,7 @@ type
   TCustomSQLScript = class(TComponent)
   private
     FAutoCommit: Boolean;
+    FDollarStrings: Tstrings;
     FLine: Integer;
     FCol: Integer;
     FDefines: TStrings;
@@ -43,6 +47,7 @@ type
     FSkipModeStack: array[0..255] of TSQLSkipMode;
     FIsSkippingStack: array[0..255] of Boolean;
     FAborted: Boolean;
+    FUseDollarString: Boolean;
     FUseSetTerm, FUseDefines, FUseCommit,
     FCommentsInSQL: Boolean;
     FTerminator: AnsiString;
@@ -52,12 +57,18 @@ type
     FDirectives: TStrings;
     FComment,
     FEmitLine: Boolean;
+    FSeps : Array of string;
     procedure SetDefines(const Value: TStrings);
-    function FindNextSeparator(sep: array of string): AnsiString;
+    function  FindNextSeparator(ASeps: Array of string; Out IsExtended : Boolean): AnsiString;
     procedure AddToStatement(value: AnsiString; ForceNewLine : boolean);
     procedure SetDirectives(value: TStrings);
+    procedure SetDollarStrings(AValue: TStrings);
     procedure SetSQL(value: TStrings);
+    procedure SetTerminator(AValue: AnsiString);
+    procedure SetUseDollarString(AValue: Boolean);
     procedure SQLChange(Sender: TObject);
+    procedure DollarStringsChange(Sender : TObject);
+    Procedure RecalcSeps;
     function GetLine: Integer;
   protected
     procedure ClearStatement; virtual;
@@ -86,10 +97,12 @@ type
     property UseSetTerm: Boolean read FUseSetTerm write FUseSetTerm;
     property UseCommit: Boolean read FUseCommit write FUseCommit;
     property UseDefines: Boolean read FUseDefines write FUseDefines;
+    Property UseDollarString : Boolean Read FUseDollarString Write SetUseDollarString;
+    Property DollarStrings : TStrings Read FDollarStrings Write SetDollarStrings;
     property Defines : TStrings Read FDefines Write SetDefines;
     property Directives: TStrings read FDirectives write SetDirectives;
     property Script: TStrings read FSQL write SetSQL;  // script to execute
-    property Terminator: AnsiString read FTerminator write FTerminator;
+    property Terminator: AnsiString read FTerminator write SetTerminator;
     property OnException : TSQLScriptExceptionEvent read FOnException write FOnException;
   end;
 
@@ -155,21 +168,21 @@ begin
   Result := Result and ((L2 = L1) or (s1[L2+1] = ' '));
 end;
 
-function GetFirstSeparator(S: AnsiString; Sep: array of string): AnsiString;
+function GetFirstSeparator(S: AnsiString; Sep: array of string): integer;
 
 var
   i, C, M: Integer;
 
 begin
   M:=length(S) + 1;
-  Result:='';
+  Result:=-1;
   for i:=0 to high(Sep) do
     begin
     C:=Pos(Sep[i],S);
     if (C<>0) and (C<M) then
       begin
       M:=C;
-      Result:=Sep[i];
+      Result:=i;
       end;
     end;
 end;
@@ -192,6 +205,34 @@ begin
   FCol:=1;
 end;
 
+procedure TCustomSQLScript.DollarStringsChange(Sender: TObject);
+begin
+  RecalcSeps;
+end;
+
+procedure TCustomSQLScript.RecalcSeps;
+
+Var
+  L : Integer;
+
+begin
+  L:=MinSQLSeps;
+  If UseDollarString then
+     L:=L+1+DollarStrings.Count;
+  SetLength(FSeps,L);
+  FSeps[0]:=FTerminator;
+  FSeps[1]:='/*';
+  FSeps[2]:='"';
+  FSeps[3]:='''';
+  FSeps[4]:='--';
+  If UseDollarString then
+    begin
+    FSeps[MinSQLSeps]:='$$';
+    For L:=0 to FDollarStrings.Count-1 do
+      FSeps[MinSQLSeps+1+L]:='$'+FDollarStrings[L]+'$';
+    end;
+end;
+
 procedure TCustomSQLScript.SetDirectives(value: TStrings);
 
 var 
@@ -212,6 +253,14 @@ begin
   DefaultDirectives;
 end;
 
+procedure TCustomSQLScript.SetDollarStrings(AValue: TStrings);
+begin
+  if FDollarStrings=AValue then Exit;
+  FDollarStrings.Assign(AValue);
+  If FUseDollarString then
+    RecalcSeps;
+end;
+
 procedure TCustomSQLScript.SetSQL(value: TStrings);
 begin
   FSQL.Assign(value);
@@ -219,12 +268,27 @@ begin
   FCol:=1;
 end;
 
+procedure TCustomSQLScript.SetTerminator(AValue: AnsiString);
+begin
+  if FTerminator=AValue then Exit;
+  FTerminator:=AValue;
+  if Length(FSeps)>0 then
+    FSeps[0]:=FTerminator;
+end;
+
+procedure TCustomSQLScript.SetUseDollarString(AValue: Boolean);
+begin
+  if FUseDollarString=AValue then Exit;
+  FUseDollarString:=AValue;
+  RecalcSeps;
+end;
 function TCustomSQLScript.GetLine: Integer;
 begin
   Result:=FLine - 1;
 end;
 
-procedure TCustomSQLScript.AddToStatement(value: AnsiString; ForceNewLine : Boolean);
+procedure TCustomSQLScript.AddToStatement(value: AnsiString;
+  ForceNewLine: boolean);
 
   Procedure DA(L : TStrings);
 
@@ -242,10 +306,12 @@ begin
     DA(FCurrentStripped);
 end;
 
-function TCustomSQLScript.FindNextSeparator(Sep: array of string): AnsiString;
+function TCustomSQLScript.FindNextSeparator(ASeps: array of string; out
+  IsExtended: Boolean): AnsiString;
 
 var
   S: AnsiString;
+  I : Integer;
 
 begin
   Result:='';
@@ -256,8 +322,8 @@ begin
       begin
       S:=Copy(S,FCol,length(S));
       end;
-    Result:=GetFirstSeparator(S,Sep);
-    if (Result='') then
+    I:=GetFirstSeparator(S,ASeps);
+    if (I=-1) then
       begin
       if FEmitLine then
         AddToStatement(S,(FCol<=1));
@@ -266,6 +332,8 @@ begin
       end
     else
       begin
+      Result:=ASeps[i];
+      IsExtended:=I>=MinSQLSeps;
       if FEmitLine then
         AddToStatement(Copy(S,1,Pos(Result,S)-1),(FCol=1));
       FCol:=(FCol-1)+Pos(Result,S);
@@ -446,14 +514,14 @@ function TCustomSQLScript.NextStatement: AnsiString;
 
 var
   pnt: AnsiString;
-  terminator_found: Boolean;
+  b,isExtra,terminator_found: Boolean;
 
 begin
   terminator_found:=False;
   ClearStatement;
   while FLine <= FSQL.Count do
     begin
-    pnt:=FindNextSeparator([FTerminator, '/*', '"', '''', '--']);
+    pnt:=FindNextSeparator(FSeps,isExtra);
     if (pnt=FTerminator) then
       begin
       FCol:=FCol + length(pnt);
@@ -468,7 +536,7 @@ begin
       else
         FEmitLine:=False;
       FCol:=FCol + length(pnt);
-      pnt:=FindNextSeparator(['*/']);
+      pnt:=FindNextSeparator(['*/'],b);
       if FCommentsInSQL then
         AddToStatement(pnt,false)
       else
@@ -489,7 +557,7 @@ begin
       begin
       AddToStatement(pnt,false);
       FCol:=FCol + length(pnt);
-      pnt:=FindNextSeparator(['"']);
+      pnt:=FindNextSeparator(['"'],b);
       AddToStatement(pnt,false);
       FCol:=FCol + length(pnt);
       end
@@ -497,9 +565,17 @@ begin
       begin
       AddToStatement(pnt,False);
       FCol:=FCol + length(pnt);
-      pnt:=FindNextSeparator(['''']);
+      pnt:=FindNextSeparator([''''],b);
       AddToStatement(pnt,false);
       FCol:=FCol + length(pnt);
+      end
+    else if IsExtra then
+      begin
+        AddToStatement(pnt,false);
+        FCol:=FCol + length(pnt);
+        pnt:=FindNextSeparator([pnt],b);
+        AddToStatement(pnt,false);
+        FCol:=FCol + length(pnt);
       end;
     end;
   if not terminator_found then
@@ -511,7 +587,7 @@ begin
   Result:=FCurrentStatement.Text;
 end;
 
-Constructor TCustomSQLScript.Create (AnOwner: TComponent);
+constructor TCustomSQLScript.Create(AnOwner: TComponent);
 
 Var
   L : TStringList;
@@ -530,6 +606,10 @@ begin
   L:=TStringList.Create();
   L.OnChange:=@SQLChange;
   FSQL:=L;
+  L:=TStringList.Create();
+  L.OnChange:=@DollarStringsChange;
+  FDollarStrings:=L;
+  ReCalcSeps;
   FDirectives:=TStringList.Create();
   FCurrentStripped:=TStringList.Create();
   FCurrentStatement:=TStringList.Create();
@@ -584,7 +664,8 @@ begin
     end;
 end;
 
-Function TCustomSQLScript.ProcessConditional(Directive: String; Param : String) : Boolean;
+function TCustomSQLScript.ProcessConditional(Directive: String; Param: String
+  ): Boolean;
 
   Procedure PushSkipMode;
 

packages/fcl-db/tests/testsqlscript.pas

@@ -44,6 +44,8 @@ type
     property DoException : string read FExcept write FExcept;
     property Aborted;
     property Line;
+    property UseDollarString;
+    property dollarstrings;
     property Directives;
     property Defines;
     property Script;
@@ -114,6 +116,9 @@ type
     procedure TestDirectiveOnException2;
     procedure TestCommitOnException1;
     procedure TestCommitOnException2;
+    procedure TestUseDollarSign;
+    procedure TestUseDollarSign2;
+    procedure TestUseDollarSign3;
   end;
 
   { TTestEventSQLScript }
@@ -693,6 +698,77 @@ begin
   AssertEquals ('commit count', 1, Script.FCommits);
 end;
 
+
+Const
+  PLSQL1 = 'CREATE or replace FUNCTION test_double_bad_sum ( value1 int, value2 int ) '+
+    'RETURNS int AS $$  '+
+    'DECLARE  '+
+    '  TheDoubleSum int;  '+
+    'BEGIN  '+
+    '  -- Start  '+
+    '  TheDoubleSum := value1; '+
+    '  /* sum  '+
+    '       number  '+
+    '       1 */  '+
+    '  TheDoubleSum := TheDoubleSum + value2; '+
+    '  TheDoubleSum := TheDoubleSum + value2; -- Sum number 2  '+
+    '  return TheDoubleSum; '+
+    'END;  '+
+    '$$ '+
+    'LANGUAGE plpgsql';
+  PLSQL2 = 'COMMENT ON FUNCTION test_double_bad_sum(IN integer, IN integer) '+
+    '  IS ''Just a  '+
+    '  test function '+
+    '  !!!''';
+  PLSQL3 = 'CREATE or replace FUNCTION test_double_bad_sum ( value1 int, value2 int ) '+
+    'RETURNS int AS $BOB$  '+
+    'DECLARE  '+
+    '  TheDoubleSum int;  '+
+    'BEGIN  '+
+    '  -- Start  '+
+    '  TheDoubleSum := value1; '+
+    '  /* sum  '+
+    '       number  '+
+    '       1 */  '+
+    '  TheDoubleSum := TheDoubleSum + value2; '+
+    '  TheDoubleSum := TheDoubleSum + value2; -- Sum number 2  '+
+    '  return TheDoubleSum; '+
+    'END;  '+
+    '$BOB$ '+
+    'LANGUAGE plpgsql';
+
+procedure TTestSQLScript.TestUseDollarSign;
+
+begin
+  script.UseDollarString:=True;
+  Add(PLSQL1+';');
+  script.execute;
+  // Double quotes because there are spaces.
+  AssertStatDir('"'+plsql1+'"', '');
+end;
+
+procedure TTestSQLScript.TestUseDollarSign2;
+begin
+  script.UseDollarString:=True;
+  Add(PLSQL1+';');
+  Add(PLSQL2+';');
+  script.execute;
+  // Double quotes because there are spaces.
+  AssertStatDir('"'+plsql1+'","'+PLSQL2+'"', '');
+
+end;
+
+procedure TTestSQLScript.TestUseDollarSign3;
+begin
+  script.UseDollarString:=True;
+  script.DollarStrings.Add('BOB');
+  Add(PLSQL3+';');
+  script.execute;
+  // Double quotes because there are spaces.
+  AssertStatDir('"'+plsql3+'"', '');
+
+end;
+
 { TTestEventSQLScript }
 
 procedure TTestEventSQLScript.Notify(Sender: TObject);