Merged revisions 10861-10864,10875,10882,10891,10907,10909,10915-10916,10922-10923,10928,10930,10933,10935,10939,10942,10948,10952-10956,10960,10964-10965,10972,10974-10975,10977,10980,10982-10983,10985,10993,11000,11016,11032-11033,11042,11044,11046,11053,11060,11062,11064,11067,11075,11078,11080,11085-11086,11089,11094,11096,11098,11103-11104,11106,11108-11109,11111,11114,11117,11122,11124,11126,11130-11131,11133,11136,11139-11141,11146-11147,11152-11154,11157,11159,11166-11167,11170,11173,11178,11181-11182,11184-11185,11187-11189,11195-11196,11206-11209,11214-11215,11223,11225,11227,11232,11235,11239-11240,11249-11256,11258,11260-11261,11264-11265,11268,11271,11278,11280-11282,11286-11288,11292-11294,11297,11299-11300,11302,11304-11313,11315-11316,11318-11319,11324-11326,11328-11333,11335-11336,11339-11340,11346-11347,11349,11351-11352,11354-11356,11362-11366,11369,11371-11375,11387,11393-11396,11401,11411-11414,11420,11422,11427-11428,11465,11469-11470,11487-11488,11490,11518-11521,11523,11528,11535,11551,11553,11555,11557,11562,11564,11571,11588,11619,11621-11622,11628,11664-11667,11670,11682-11683,11685,11689-11692,11694-11696,11698,11701-11702,11705-11707,11712-11718,11723-11726,11728-11729,11733-11737,11778,11780-11781,11785,11810,11822,11831,11836,11848,11870 via svnmerge from

svn+ssh://svn.freepascal.org/FPC/svn/fpc/trunk

........
  r10861 | michael | 2008-05-02 18:00:48 +0200 (Fri, 02 May 2008) | 1 line
  
  * Fixed some typos
........
  r11016 | michael | 2008-05-19 21:04:50 +0200 (Mon, 19 May 2008) | 1 line
  
  * Writing to file log now also will raise an error
........
  r11086 | michael | 2008-05-26 20:26:47 +0200 (Mon, 26 May 2008) | 1 line
  
  * Added bucket lists implementation
........
  r11261 | michael | 2008-06-21 23:13:25 +0200 (Sat, 21 Jun 2008) | 1 line
  
  * Fixed reading of alternate font name
........
  r11268 | michael | 2008-06-23 21:38:40 +0200 (Mon, 23 Jun 2008) | 1 line
  
  * Fixed style reading for OOffice documents
........
  r11312 | michael | 2008-07-02 18:23:13 +0200 (Wed, 02 Jul 2008) | 1 line
  
  * Fixed memory leak when re-assigning datasource property
........
  r11351 | michael | 2008-07-09 15:49:05 +0200 (Wed, 09 Jul 2008) | 1 line
  
  * Fixed saving/restoring of precision in TDDFielddef
........
  r11352 | michael | 2008-07-09 15:50:12 +0200 (Wed, 09 Jul 2008) | 1 line
  
  * Code generator for populating a data dictionary in code
........
  r11354 | michael | 2008-07-10 11:08:40 +0200 (Thu, 10 Jul 2008) | 1 line
  
  * Improvements to tiopf code generator, and build project for use with lazarus
........
  r11355 | michael | 2008-07-10 11:40:37 +0200 (Thu, 10 Jul 2008) | 1 line
  
  * Corrected int64 type name
........
  r11356 | michael | 2008-07-10 16:37:27 +0200 (Thu, 10 Jul 2008) | 1 line
  
  * Fixes so it compiles in all cases
........
  r11363 | michael | 2008-07-11 14:41:40 +0200 (Fri, 11 Jul 2008) | 1 line
  
  * Support for indexes and creating sql from them
........
  r11364 | michael | 2008-07-11 14:45:52 +0200 (Fri, 11 Jul 2008) | 1 line
  
  * Set unit output path that does not disturb make
........
  r11365 | michael | 2008-07-11 14:53:32 +0200 (Fri, 11 Jul 2008) | 1 line
  
  * Session info in lps file
........
  r11366 | michael | 2008-07-11 16:16:39 +0200 (Fri, 11 Jul 2008) | 1 line
  
  * SqlScript committed 
........
  r11387 | michael | 2008-07-16 19:32:26 +0200 (Wed, 16 Jul 2008) | 1 line
  
  * ReadListClass SQL statement needs correct where, O not assigned in MapObjectToRow
........
  r11682 | michael | 2008-09-01 12:05:52 +0200 (Mon, 01 Sep 2008) | 1 line
  
  * In case no default is specified and no NoDefault is present, act as if NoDefault was given. (bug ID 10080, now we are Delphi compatible)
........
  r11870 | michael | 2008-10-09 11:55:21 +0200 (Thu, 09 Oct 2008) | 1 line
  
  * Fixed bug #12323. Bug is in getting default value of string parameters, unterminated memory copy
........

git-svn-id: branches/fixes_2_2@12080 -

.gitattributes

@@ -1122,13 +1122,17 @@ packages/fcl-db/src/base/dsparams.inc svneol=native#text/plain
 packages/fcl-db/src/base/fields.inc svneol=native#text/plain
 packages/fcl-db/src/base/fpmake.inc svneol=native#text/plain
 packages/fcl-db/src/base/fpmake.pp svneol=native#text/plain
+packages/fcl-db/src/base/sqlscript.pp svneol=native#text/plain
 packages/fcl-db/src/codegen/Makefile svneol=native#text/plain
 packages/fcl-db/src/codegen/Makefile.fpc svneol=native#text/plain
+packages/fcl-db/src/codegen/buildddcg.lpi svneol=native#text/plain
+packages/fcl-db/src/codegen/buildddcg.lpr svneol=native#text/plain
 packages/fcl-db/src/codegen/fpcgcreatedbf.pp svneol=native#text/plain
 packages/fcl-db/src/codegen/fpcgdbcoll.pp svneol=native#text/plain
 packages/fcl-db/src/codegen/fpcgsqlconst.pp svneol=native#text/plain
 packages/fcl-db/src/codegen/fpcgtiopf.pp svneol=native#text/plain
 packages/fcl-db/src/codegen/fpddcodegen.pp svneol=native#text/plain
+packages/fcl-db/src/codegen/fpddpopcode.pp svneol=native#text/plain
 packages/fcl-db/src/datadict/Makefile svneol=native#text/plain
 packages/fcl-db/src/datadict/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/src/datadict/buildd.lpi svneol=native#text/plain
@@ -1286,6 +1290,7 @@ packages/fcl-db/tests/testbasics.pas svneol=native#text/plain
 packages/fcl-db/tests/testdatasources.pas svneol=native#text/plain
 packages/fcl-db/tests/testdbbasics.pas -text
 packages/fcl-db/tests/testfieldtypes.pas svneol=native#text/plain
+packages/fcl-db/tests/testsqlscript.pas svneol=native#text/plain
 packages/fcl-db/tests/toolsunit.pas -text
 packages/fcl-fpcunit/Makefile svneol=native#text/plain
 packages/fcl-fpcunit/Makefile.fpc svneol=native#text/plain

compiler/pdecvar.pas

@@ -214,6 +214,26 @@ implementation
              end;
           end;
 
+          function allow_default_property(p : tpropertysym) : boolean;
+
+          begin
+             allow_default_property:=
+               (is_ordinal(p.propdef) or
+{$ifndef cpu64bitaddr}
+               is_64bitint(p.propdef) or
+{$endif cpu64bitaddr}
+               is_class(p.propdef) or
+               is_single(p.propdef) or
+               (p.propdef.typ in [classrefdef,pointerdef]) or
+                 is_smallset(p.propdef)
+               ) and not
+               (
+                (p.propdef.typ=arraydef) and
+                (ppo_indexed in p.propoptions)
+               ) and not
+               (ppo_hasparameters in p.propoptions);
+          end;
+
       var
          sym : tsym;
          p : tpropertysym;
@@ -562,18 +582,7 @@ implementation
            end;
          if try_to_consume(_DEFAULT) then
            begin
-              if not(is_ordinal(p.propdef) or
-{$ifndef cpu64bit}
-                     is_64bitint(p.propdef) or
-{$endif cpu64bit}
-                     is_class(p.propdef) or
-                     is_single(p.propdef) or
-                     (p.propdef.typ in [classrefdef,pointerdef]) or
-                     ((p.propdef.typ=setdef) and
-                      (tsetdef(p.propdef).settype=smallset))) or
-                     ((p.propdef.typ=arraydef) and
-                      (ppo_indexed in p.propoptions)) or
-                 (ppo_hasparameters in p.propoptions) then
+              if not allow_default_property(p) then
                 begin
                   Message(parser_e_property_cant_have_a_default_value);
                   { Error recovery }
@@ -609,9 +618,14 @@ implementation
                 end;
            end
          else if try_to_consume(_NODEFAULT) then
+           begin
+              p.default:=longint($80000000);
+           end
+         else if allow_default_property(p) then
            begin
               p.default:=longint($80000000);
            end;
+  
          { Parse possible "implements" keyword }
          if try_to_consume(_IMPLEMENTS) then
            begin

compiler/symdef.pas

@@ -2803,7 +2803,13 @@ implementation
                   case hpc.consttyp of
                     conststring,
                     constresourcestring :
-                      hs:=strpas(pchar(hpc.value.valueptr));
+                      begin
+                      If hpc.value.len>0 then
+                        begin
+                        setLength(hs,hpc.value.len);
+                        move(hpc.value.valueptr^,hs[1],hpc.value.len);
+                        end;
+                      end;
                     constreal :
                       str(pbestreal(hpc.value.valueptr)^,hs);
                     constpointer :

packages/fcl-base/src/contnrs.pp

@@ -471,22 +471,113 @@ type
     Property OwnsObjects : Boolean Read FOwnsObjects Write FOwnsObjects;
   end;
 
-
   EDuplicate = class(Exception);
   EKeyNotFound = class(Exception);
 
-
   function RSHash(const S: string; const TableSize: Longword): Longword;
 
+{ ---------------------------------------------------------------------
+    Bucket lists as in Delphi
+  ---------------------------------------------------------------------}
+  
+
+Type
+  TBucketItem = record
+    Item, Data: Pointer;
+  end;
+  TBucketItemArray = array of TBucketItem;
+
+  TBucket = record
+    Count : Integer;
+    Items : TBucketItemArray;
+  end;
+  PBucket = ^TBucket;
+  TBucketArray = array of TBucket;
+
+  TBucketProc = procedure(AInfo, AItem, AData: Pointer; out AContinue: Boolean);
+  TBucketProcObject = procedure(AItem, AData: Pointer; out AContinue: Boolean) of Object;
+
+{ ---------------------------------------------------------------------
+  TCustomBucketList
+  ---------------------------------------------------------------------}
+
+  { TCustomBucketList }
+
+  TCustomBucketList = class(TObject)
+  private
+    FBuckets: TBucketArray;
+    function GetBucketCount: Integer;
+    function GetData(AItem: Pointer): Pointer;
+    procedure SetData(AItem: Pointer; const AData: Pointer);
+    procedure SetBucketCount(const Value: Integer);
+  protected
+    Procedure GetBucketItem(AItem: Pointer; out ABucket, AIndex: Integer);
+    function AddItem(ABucket: Integer; AItem, AData: Pointer): Pointer; virtual;
+    function BucketFor(AItem: Pointer): Integer; virtual; abstract;
+    function DeleteItem(ABucket: Integer; AIndex: Integer): Pointer; virtual;
+    Procedure Error(Msg : String; Args : Array of Const);
+    function FindItem(AItem: Pointer; out ABucket, AIndex: Integer): Boolean; virtual;
+    property Buckets: TBucketArray read FBuckets;
+    property BucketCount: Integer read GetBucketCount write SetBucketCount;
+  public
+    destructor Destroy; override;
+    procedure Clear;
+    function Add(AItem, AData: Pointer): Pointer;
+    procedure Assign(AList: TCustomBucketList);
+    function Exists(AItem: Pointer): Boolean;
+    function Find(AItem: Pointer; out AData: Pointer): Boolean;
+    function ForEach(AProc: TBucketProc; AInfo: Pointer = nil): Boolean;
+    function ForEach(AProc: TBucketProcObject): Boolean;
+    function Remove(AItem: Pointer): Pointer;
+    property Data[AItem: Pointer]: Pointer read GetData write SetData; default;
+  end;
+
+{ ---------------------------------------------------------------------
+  TBucketList
+  ---------------------------------------------------------------------}
+  
+
+  TBucketListSizes = (bl2, bl4, bl8, bl16, bl32, bl64, bl128, bl256);
+
+  { TBucketList }
+
+  TBucketList = class(TCustomBucketList)
+  private
+    FBucketMask: Byte;
+  protected
+    function BucketFor(AItem: Pointer): Integer; override;
+  public
+    constructor Create(ABuckets: TBucketListSizes = bl16);
+  end;
+
+{ ---------------------------------------------------------------------
+  TObjectBucketList
+  ---------------------------------------------------------------------}
+  
+  { TObjectBucketList }
+
+  TObjectBucketList = class(TBucketList)
+  protected
+    function GetData(AItem: TObject): TObject;
+    procedure SetData(AItem: TObject; const AData: TObject);
+  public
+    function Add(AItem, AData: TObject): TObject;
+    function Remove(AItem: TObject): TObject;
+    property Data[AItem: TObject]: TObject read GetData write SetData; default;
+  end;
+
+
 implementation
 
 uses
   RtlConsts;
 
 ResourceString
-  DuplicateMsg = 'An item with key %0:s already exists';
+  DuplicateMsg   = 'An item with key %0:s already exists';
   KeyNotFoundMsg = 'Method: %0:s key [''%1:s''] not found in container';
-  NotEmptyMsg = 'Hash table not empty.';
+  NotEmptyMsg    = 'Hash table not empty.';
+  SErrNoSuchItem = 'No item in list for %p';
+  SDuplicateItem = 'Item already exists in list: %p';
 
 const
   NPRIMES = 28;
@@ -2335,4 +2426,291 @@ begin
   Inherited;
 end;
 
+{ TCustomBucketList }
+
+function TCustomBucketList.GetData(AItem: Pointer): Pointer;
+
+Var
+  B,I : Integer;
+
+begin
+  GetBucketItem(AItem,B,I);
+  Result:=FBuckets[B].Items[I].Data;
+end;
+
+function TCustomBucketList.GetBucketCount: Integer;
+begin
+  Result:=Length(FBuckets);
+end;
+
+procedure TCustomBucketList.SetData(AItem: Pointer; const AData: Pointer);
+
+Var
+  B,I : Integer;
+
+begin
+  GetBucketItem(AItem,B,I);
+  FBuckets[B].Items[I].Data:=AData;
+end;
+
+procedure TCustomBucketList.SetBucketCount(const Value: Integer);
+
+begin
+  If (Value<>GetBucketCount) then
+    SetLength(FBuckets,Value);
+end;
+
+procedure TCustomBucketList.GetBucketItem(AItem: Pointer; out ABucket,
+  AIndex: Integer);
+begin
+  If Not FindItem(AItem,ABucket,AIndex) then
+    Error(SErrNoSuchItem,[AItem]);
+end;
+
+function TCustomBucketList.AddItem(ABucket: Integer; AItem, AData: Pointer
+  ): Pointer;
+  
+Var
+  B : PBucket;
+  L : Integer;
+  
+begin
+  B:=@FBuckets[ABucket];
+  L:=Length(B^.Items);
+  If (B^.Count=L) then
+    begin
+    If L<8 then
+      L:=8
+    else
+      L:=L+L div 2;
+    SetLength(B^.Items,L);
+    end;
+  With B^ do
+    begin
+    Items[Count].Item:=AItem;
+    Items[Count].Data:=AData;
+    Result:=AData;
+    Inc(Count);
+    end;
+end;
+
+function TCustomBucketList.DeleteItem(ABucket: Integer; AIndex: Integer): Pointer;
+  
+Var
+  B : PBucket;
+  L : Integer;
+  
+begin
+  B:=@FBuckets[ABucket];
+  Result:=B^.Items[Aindex].Data;
+  If B^.Count=1 then
+    SetLength(B^.Items,0)
+  else
+    begin
+    L:=(B^.Count-AIndex-1);// No point in moving if last one...
+    If L>0 then
+      Move(B^.Items[AIndex+1],B^.Items[AIndex],L*SizeOf(TBucketItem));
+    end;
+  Dec(B^.Count);
+end;
+
+procedure TCustomBucketList.Error(Msg: String; Args: array of const);
+begin
+  Raise ElistError.CreateFmt(Msg,Args);
+end;
+
+function TCustomBucketList.FindItem(AItem: Pointer; out ABucket, AIndex: Integer
+  ): Boolean;
+  
+Var
+  I : Integer;
+  B : TBucket;
+  
+begin
+  ABucket:=BucketFor(AItem);
+  B:=FBuckets[ABucket];
+  I:=B.Count-1;
+  While (I>=0) And (B.Items[I].Item<>AItem) do
+    Dec(I);
+  Result:=I>=0;
+  If Result then
+    AIndex:=I;
+end;
+
+destructor TCustomBucketList.Destroy;
+begin
+  Clear;
+  inherited Destroy;
+end;
+
+procedure TCustomBucketList.Clear;
+
+Var
+  B : TBucket;
+  I,J : Integer;
+
+begin
+  For I:=0 to Length(FBuckets)-1 do
+    begin
+    B:=FBuckets[I];
+    For J:=B.Count-1 downto 0 do
+      DeleteItem(I,J);
+    end;
+  SetLength(FBuckets,0);
+end;
+
+function TCustomBucketList.Add(AItem, AData: Pointer): Pointer;
+
+Var
+  B,I : Integer;
+
+begin
+  If FindItem(AItem,B,I) then
+    Error(SDuplicateItem,[AItem]);
+  Result:=AddItem(B,AItem,AData);
+end;
+
+procedure TCustomBucketList.Assign(AList: TCustomBucketList);
+
+Var
+  I,J : Integer;
+
+begin
+  Clear;
+  SetLength(FBuckets,Length(Alist.FBuckets));
+  For I:=0 to BucketCount-1 do
+    begin
+    SetLength(FBuckets[i].Items,Length(AList.Fbuckets[I].Items));
+    For J:=0 to AList.Fbuckets[I].Count-1 do
+      With AList.Fbuckets[I].Items[J] do
+        AddItem(I,Item,Data);
+    end;
+end;
+
+function TCustomBucketList.Exists(AItem: Pointer): Boolean;
+
+Var
+  B,I : Integer;
+
+begin
+  Result:=FindItem(Aitem,B,I);
+end;
+
+function TCustomBucketList.Find(AItem: Pointer; out AData: Pointer): Boolean;
+
+Var
+  B,I : integer;
+
+begin
+  Result:=FindItem(AItem,B,I);
+  If Result then
+    AData:=FBuckets[B].Items[I].Data;
+end;
+
+function TCustomBucketList.ForEach(AProc: TBucketProc; AInfo: Pointer
+  ): Boolean;
+  
+Var
+  I,J,S : Integer;
+  Bu : TBucket;
+  
+begin
+  I:=0;
+  Result:=True;
+  S:=GetBucketCount;
+  While Result and (I<S) do
+    begin
+    J:=0;
+    Bu:=FBuckets[I];
+    While Result and (J<Bu.Count) do
+      begin
+      With Bu.Items[J] do
+        AProc(AInfo,Item,Data,Result);
+      Inc(J);
+      end;
+    Inc(I);
+    end;
+end;
+
+function TCustomBucketList.ForEach(AProc: TBucketProcObject): Boolean;
+
+Var
+  I,J,S : Integer;
+  Bu : TBucket;
+
+begin
+  I:=0;
+  Result:=True;
+  S:=GetBucketCount;
+  While Result and (I<S) do
+    begin
+    J:=0;
+    Bu:=FBuckets[I];
+    While Result and (J<Bu.Count) do
+      begin
+      With Bu.Items[J] do
+        AProc(Item,Data,Result);
+      Inc(J);
+      end;
+    Inc(I);
+    end;
+end;
+
+function TCustomBucketList.Remove(AItem: Pointer): Pointer;
+
+Var
+  B,I : integer;
+
+begin
+  If FindItem(AItem,B,I) then
+    begin
+    Result:=FBuckets[B].Items[I].Data;
+    DeleteItem(B,I);
+    end
+  else
+    Result:=Nil;
+end;
+
+{ TBucketList }
+
+function TBucketList.BucketFor(AItem: Pointer): Integer;
+begin
+  // Pointers on average have a granularity of 4
+  Result:=(PtrInt(AItem) shr 2) and FBucketMask;
+end;
+
+constructor TBucketList.Create(ABuckets: TBucketListSizes);
+
+Var
+  L : Integer;
+  
+begin
+  Inherited Create;
+  L:=1 shl (Ord(Abuckets)+1);
+  SetBucketCount(L);
+  FBucketMask:=L-1;
+end;
+
+{ TObjectBucketList }
+
+function TObjectBucketList.GetData(AItem: TObject): TObject;
+begin
+  Result:=TObject(Inherited GetData(AItem));
+end;
+
+procedure TObjectBucketList.SetData(AItem: TObject; const AData: TObject);
+begin
+  Inherited SetData(Pointer(AItem),Pointer(AData));
+end;
+
+function TObjectBucketList.Add(AItem, AData: TObject): TObject;
+begin
+  Result:=TObject(Inherited Add(Pointer(AItem),Pointer(AData)));
+end;
+
+function TObjectBucketList.Remove(AItem: TObject): TObject;
+begin
+  Result:=TObject(Inherited Remove(Pointer(AItem)));
+end;
+
 end.

packages/fcl-base/src/eventlog.pp

@@ -102,12 +102,13 @@ Type
 
 Resourcestring
 
-  SLogInfo    = 'Info';
-  SLogWarning = 'Warning';
-  SLogError   = 'Error';
-  SLogDebug   = 'Debug';
-  SLogCustom  = 'Custom (%d)';
-
+  SLogInfo      = 'Info';
+  SLogWarning   = 'Warning';
+  SLogError     = 'Error';
+  SLogDebug     = 'Debug';
+  SLogCustom    = 'Custom (%d)';
+  SErrLogFailedMsg = 'Failed to log entry (Error: %s)';
+  
 implementation
 
 {$i eventlog.inc}
@@ -190,7 +191,15 @@ begin
   TS:=FormatDateTime(FTimeStampFormat,Now);
   T:=EventTypeToString(EventType);
   S:=Format('%s [%s %s] %s%s',[Identification,TS,T,Msg,LineEnding]);
-  FStream.Write(S[1],Length(S));
+  try
+    FStream.WriteBuffer(S[1],Length(S));
+    S:='';
+  except
+    On E : Exception do
+      S:=E.Message;
+  end;  
+  If (S<>'') and RaiseExceptionOnError then
+    Raise ELogError.CreateFmt(SErrLogFailedMsg,[S]);
 end;
 
 procedure TEventLog.Log(Fmt: String; Args: array of const);

packages/fcl-base/src/rtfpars.pp

@@ -85,6 +85,7 @@ TRTFParser = class(TObject)
     Procedure UngetToken;
     Procedure SetToken (Aclass, major, minor, param : Integer; text : string);
     Procedure ExpandStyle (n : Integer);
+    Function GetRtfBuf : String;
     { Properties }
     Property Colors [Index : Integer]: PRTFColor Read GetColor;
     Property ClassCallBacks [AClass : Integer]: TRTFFuncptr
@@ -728,6 +729,13 @@ While true do
      Error ('FTErr - missing font name');
   fp^.rtffname:=bp;
   { Read alternate font}
+  if rtfclass=rtfgroup then
+    begin
+    SkipGroup;
+    if Not rtfMajor=ord(';') then
+      Error('Alternate font badly terminated');
+    GetToken;
+    end;
   if (old=0) then       { need to see "End;" here }
     Begin
     GetToken;
@@ -795,6 +803,7 @@ var
   sp          : PRTFStyle;
   sep,sepLast : PRTFStyleElt;
   bp          : string[rtfBufSiz];
+  I : Integer;
 
 Begin
 While true do
@@ -815,40 +824,40 @@ While true do
   FstyleList := sp;
   if not CheckCM (rtfGroup, rtfBeginGroup) then
      Error ('SSErr - missing {');
-  while (GetToken=rtfControl) or (FTokenClass=rtfControl) do
+  I:=0;
+  GetToken;
+  while (fRTFClass=rtfControl) or (FTokenClass=rtfControl) or (FRTFClass=rtfGroup) do
     Begin
-    if rtfClass=rtfUnknown then
-      continue;
-    if (CheckMM (rtfParAttr, rtfStyleNum)) then
-      Begin
-      sp^.rtfSNum:=rtfParam;
-      continue;
-      End;
-    if (CheckMM (rtfStyleAttr, rtfBasedOn)) then
-      Begin
-      sp^.rtfSBasedOn:=rtfParam;
-      continue;
-      End;
-    if (CheckMM (rtfStyleAttr, rtfNext)) then
-      Begin
-      sp^.rtfSNextPar:=rtfParam;
-      Continue;
-      End;
-    new(sep);
-    if sep=nil then
-      Error ('SSErr - cannot allocate style element');
-    sep^.rtfSEClass:=rtfClass;
-    sep^.rtfSEMajor:=rtfMajor;
-    sep^.rtfSEMinor:=rtfMinor;
-    sep^.rtfSEParam:=rtfParam;
-    sep^.rtfSEText:=rtfTextBuf;
-    if sepLast=nil then
-       sp^.rtfSSEList:=sep      { first element }
-    else                                { add to end }
-       sepLast^.rtfNextSE:=sep;
-    sep^.rtfNextSE:=nil;
-    sepLast:=sep;
-  End;
+    If CheckCM(rtfGroup, rtfBeginGroup) then
+      SkipGroup
+    else if rtfClass<>rtfUnknown then
+      begin
+      if (CheckMM (rtfParAttr, rtfStyleNum)) then
+        sp^.rtfSNum:=rtfParam
+      else if (CheckMM (rtfStyleAttr, rtfBasedOn)) then
+        sp^.rtfSBasedOn:=rtfParam
+      else if (CheckMM (rtfStyleAttr, rtfNext)) then
+        sp^.rtfSNextPar:=rtfParam
+      else
+        begin
+        new(sep);
+        if sep=nil then
+          Error ('SSErr - cannot allocate style element');
+        sep^.rtfSEClass:=rtfClass;
+        sep^.rtfSEMajor:=rtfMajor;
+        sep^.rtfSEMinor:=rtfMinor;
+        sep^.rtfSEParam:=rtfParam;
+        sep^.rtfSEText:=rtfTextBuf;
+        if sepLast=nil then
+           sp^.rtfSSEList:=sep      { first element }
+        else                                { add to end }
+           sepLast^.rtfNextSE:=sep;
+        sep^.rtfNextSE:=nil;
+        sepLast:=sep;
+        end;
+      end;
+    GetToken;
+    End;
   if sp^.rtfSNextPar=-1 then            { \snext not given }
     sp^.rtfSNextPar:=sp^.rtfSNum;       { next is itself }
   if rtfClass<>rtfText then
@@ -994,6 +1003,11 @@ while se<>nil do
 s^.rtfExpanding:=0;     { done - clear expansion flag }
 End;
 
+function TRTFParser.GetRtfBuf: String;
+begin
+  Result:=rtfTextBuf;
+end;
+
 { ---------------------------------------------------------------------
        Initialize lookup table hash values.
        Only need to do this the first time it's called.

packages/fcl-db/src/base/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/06/15]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/06/23]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@@ -261,178 +261,178 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages $(FPCDIR)/packages/base $(F
 override PACKAGE_NAME=fcl-db
 PACKAGEDIR_MAIN:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /fcl-db/Makefile.fpc,$(PACKAGESDIR))))))
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-os2)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-haiku)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-netware)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-darwin)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-emx)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-watcom)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-netwlibc)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-symbian)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-atari)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),m68k-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-amiga)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),sparc-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),x86_64-darwin)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),x86_64-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-palmos)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-darwin)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-gba)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-nds)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),arm-symbian)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc64-darwin)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),powerpc64-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),avr-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),armeb-linux)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),armeb-embedded)
-override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+override TARGET_UNITS+=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_RSTS+=dbwhtml dbconst dbcoll

packages/fcl-db/src/base/Makefile.fpc

@@ -6,7 +6,7 @@
 main=fcl-db
 
 [target]
-units=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll
+units=dbconst db dbwhtml bufdataset_parser bufdataset dbcoll sqlscript
 rsts=dbwhtml dbconst dbcoll
 
 [require]

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

@@ -0,0 +1,662 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    Abstract SQL scripting engine.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit sqlscript;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils; 
+
+type
+
+  TSQLScriptStatementEvent = procedure(Sender: TObject; Statement: TStrings; var StopExecution: Boolean) of object;
+  TSQLScriptDirectiveEvent = procedure(Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean) of object;
+  TSQLScriptExceptionEvent = procedure(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean) of object;
+  TSQLSkipMode = (smNone, smIfBranch, smElseBranch, smAll);
+
+  { TCustomSQLScript }
+
+  TCustomSQLScript = class(TComponent)
+  private
+    FLine: Integer;
+    FCol: Integer;
+    FDefines: TStrings;
+    FOnException: TSQLScriptExceptionEvent;
+    FSkipMode: TSQLSkipMode;
+    FIsSkipping: Boolean;
+    FSkipStackIndex: Integer;
+    FSkipModeStack: array[0..255] of TSQLSkipMode;
+    FIsSkippingStack: array[0..255] of Boolean;
+    FAborted: Boolean;
+    FUseSetTerm, FUseDefines, FUseCommit,
+    FCommentsInSQL: Boolean;
+    FTerminator: AnsiString;
+    FSQL: TStrings;
+    FCurrentStatement: TStrings;
+    FDirectives: TStrings;
+    FEmitLine: Boolean;
+    procedure SetDefines(const Value: TStrings);
+    function FindNextSeparator(sep: array of string): AnsiString;
+    procedure AddToStatement(value: AnsiString; ForceNewLine : boolean);
+    procedure SetDirectives(value: TStrings);
+    procedure SetSQL(value: TStrings);
+    procedure SQLChange(Sender: TObject);
+    function GetLine: Integer;
+    Function ProcessConditional(Directive : String; Param : String) : Boolean; virtual;
+    function NextStatement: AnsiString;
+    procedure ProcessStatement;
+    function Available: Boolean;
+    procedure InternalStatement (Statement: TStrings; var StopExecution: Boolean);
+    procedure InternalDirective (Directive, Argument: String; var StopExecution: Boolean);
+    procedure InternalCommit;
+  protected
+    procedure DefaultDirectives; virtual;
+    procedure ExecuteStatement (Statement: TStrings; var StopExecution: Boolean); virtual; abstract;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); virtual; abstract;
+    procedure ExecuteCommit; virtual; abstract;
+  public
+    constructor Create (AnOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Execute; virtual;
+  protected
+    property Aborted: Boolean read FAborted;
+    property Line: Integer read GetLine;
+    property CommentsInSQL: Boolean read FCommentsInSQL write FCommentsInSQL;
+    property UseSetTerm: Boolean read FUseSetTerm write FUseSetTerm;
+    property UseCommit: Boolean read FUseCommit write FUseCommit;
+    property UseDefines: Boolean read FUseDefines write FUseDefines;
+    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 OnException : TSQLScriptExceptionEvent read FOnException write FOnException;
+  end;
+
+  { TEventSQLScript }
+
+  TEventSQLScript = class (TCustomSQLScript)
+  private
+    FAfterExec: TNotifyEvent;
+    FBeforeExec: TNotifyEvent;
+    FOnCommit: TNotifyEvent;
+    FOnSQLStatement: TSQLScriptStatementEvent;
+    FOnDirective: TSQLScriptDirectiveEvent;
+  protected
+    procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
+    procedure ExecuteCommit; override;
+  public
+    procedure Execute; override;
+    property Aborted;
+    property Line;
+  published
+    property Directives;
+    property Defines;
+    property Script;
+    property Terminator;
+    property CommentsinSQL;
+    property UseSetTerm;
+    property UseCommit;
+    property UseDefines;
+    property OnException;
+    property OnSQLStatement: TSQLScriptStatementEvent read FOnSQLStatement write FOnSQLStatement;
+    property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
+    property OnCommit: TNotifyEvent read FOnCommit write FOnCommit;
+    property BeforeExecute : TNotifyEvent read FBeforeExec write FBeforeExec;
+    property AfterExecute : TNotifyEvent read FAfterExec write FAfterExec;
+  end;
+
+  ESQLScript = Class(Exception);
+
+implementation
+
+Resourcestring
+ SErrIfXXXNestingLimitReached = '#IFDEF nesting limit reached';
+ SErrInvalidEndif = '#ENDIF without #IFDEF';
+ SErrInvalidElse  = '#ELSE without #IFDEF';
+
+{ ---------------------------------------------------------------------
+    Auxiliary Functions
+  ---------------------------------------------------------------------}
+  
+function StartsWith(S1, S2: AnsiString): Boolean;
+
+var
+  L1,L2 : Integer;
+
+begin
+  Result:=False;
+  L1:=Length(S1);
+  L2:=Length(S2);
+  if (L2=0) or (L1<L2) then
+    Exit;
+  Result:=(AnsiCompareStr(Copy(s1,1,L2),S2)=0);
+  Result := Result and ((L2 = L1) or (s1[L2+1] = ' '));
+end;
+
+function GetFirstSeparator(S: AnsiString; Sep: array of string): AnsiString;
+
+var
+  i, C, M: Integer;
+
+begin
+  M:=length(S) + 1;
+  Result:='';
+  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];
+      end;
+    end;
+end;
+
+Function ConvertWhiteSpace(S : String) : String;
+
+begin
+  Result:=StringReplace(S,#13,' ',[rfReplaceAll]);
+  Result:=StringReplace(Result,#10,' ',[rfReplaceAll]);
+  Result:=Trim(Result);
+end;
+
+function DeleteComments(SQL_Text: AnsiString; ATerminator: AnsiString = ';'): AnsiString;
+
+begin
+  With TCustomSQLScript.Create (Nil) do
+    try
+      Terminator:=ATerminator;
+      Script.Add(SQL_Text);
+      Script.Add(Terminator);
+      CommentsInSQL:=False;
+      Result:=ConvertWhiteSpace(NextStatement);
+    finally
+      Free;
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+    TSQLScript
+  ---------------------------------------------------------------------}
+
+procedure TCustomSQLScript.SQLChange(Sender: TObject);
+begin
+  FLine:=1;
+  FCol:=1;
+end;
+
+procedure TCustomSQLScript.SetDirectives(value: TStrings);
+
+var 
+  i : Integer;
+  S : AnsiString;
+  
+begin
+  FDirectives.Clear();
+  if (Value<>Nil) then
+    begin
+    for i:=0 to value.Count - 1 do
+      begin
+      S:=UpperCase(ConvertWhiteSpace(value[i]));
+      if Length(S)>0 then 
+        FDirectives.Add(S);
+      end;
+    end;
+  DefaultDirectives;
+end;
+
+procedure TCustomSQLScript.SetSQL(value: TStrings);
+begin
+  FSQL.Assign(value);
+  FLine:=1;
+  FCol:=1;
+end;
+
+function TCustomSQLScript.GetLine: Integer;
+begin
+  Result:=FLine - 1;
+end;
+
+procedure TCustomSQLScript.AddToStatement(value: AnsiString; ForceNewLine : Boolean);
+
+begin
+  With FCurrentStatement do
+    if ForceNewLine or (Count=0) then
+      Add(value)
+    else
+      Strings[Count-1]:=Strings[Count-1] + value;
+end;
+
+function TCustomSQLScript.FindNextSeparator(Sep: array of string): AnsiString;
+
+var
+  S: AnsiString;
+
+begin
+  Result:='';
+  while (FLine<=FSQL.Count) do
+    begin
+    S:=FSQL.Strings[FLine-1];
+    if (FCol>1) then
+      begin
+      S:=Copy(S,FCol,length(S));
+      end;
+    Result:=GetFirstSeparator(S,Sep);
+    if (Result='') then
+      begin
+      if FEmitLine then
+        AddToStatement(S,(FCol=1));
+      FCol:=1;
+      FLine:=FLine+1;
+      end
+    else
+      begin
+      if FEmitLine then
+        AddToStatement(Copy(S,1,Pos(Result,S)-1),(FCol=1));
+      FCol:=(FCol-1)+Pos(Result,S);
+      break;
+      end;
+    end;
+end;
+
+function TCustomSQLScript.Available: Boolean;
+
+var 
+  SCol, 
+  SLine: Integer;
+  
+begin
+  SCol:=FCol;
+  SLine:=FLine;
+  try
+    Result:=Length(Trim(NextStatement()))>0;
+  Finally  
+    FCol:=SCol;
+    FLine:=SLine;
+  end;  
+end;
+
+procedure TCustomSQLScript.InternalStatement(Statement: TStrings;  var StopExecution: Boolean);
+
+var 
+  cont : boolean;
+  
+begin
+  try
+    ExecuteStatement(Statement, StopExecution);
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        FOnException (self, Statement, E, cont);
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TCustomSQLScript.InternalDirective(Directive, Argument: String;  var StopExecution: Boolean);
+
+var 
+  cont : boolean;
+  l : TStrings;
+  
+begin
+  try
+    ExecuteDirective(Directive, Argument, StopExecution);
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        begin
+        l := TStringlist.Create;
+        try
+          L.Add(Directive);
+          if Argument <> '' then
+            L.Add(Argument);
+          FOnException (self, l, E, cont);
+        finally
+          L.Free;
+        end;
+        end;
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TCustomSQLScript.InternalCommit;
+
+var 
+  cont : boolean;
+  l : TStrings;
+  
+begin
+  try
+    ExecuteCommit;
+  except
+    on E : Exception do
+      begin
+      cont := false;
+      if assigned (FOnException) then
+        begin
+        l := TStringlist.Create;
+        try
+          L.Add('COMMIT');
+          FOnException (self, l, E, cont);
+        finally
+          L.Free;
+        end;
+        end;
+      if not cont then
+        Raise;
+      end;
+  end;
+end;
+
+procedure TCustomSQLScript.ProcessStatement;
+
+Var
+  S,
+  Directive : String;
+  I : longint;
+
+begin
+  if (FCurrentStatement.Count=0) then
+    Exit;
+  S:=DeleteComments(FCurrentStatement.Text, Terminator);
+  I:=0;
+  Directive:='';
+  While (i<FDirectives.Count) and (Directive='') do
+    begin
+    If StartsWith(AnsiUpperCase(S), FDirectives[i]) Then
+      Directive:=FDirectives[i];
+    Inc(I);
+    end;
+  If (Directive<>'') then
+    begin
+    S:=Trim(Copy(S,Length(Directive)+1,length(S)));
+    If (Directive[1]='#') then
+      begin
+      if not FUseDefines or not ProcessConditional(Directive,S) then
+        if Not FIsSkipping then
+          InternalDirective (Directive, S, FAborted);
+      end
+    else If Not FIsSkipping then
+      begin
+      if FUseCommit and (Directive = 'COMMIT') then
+        InternalCommit
+      else if FUseSetTerm and (Directive = 'SET TERM') then
+        FTerminator:=S
+      else
+        InternalDirective (Directive,S,FAborted)
+      end
+    end
+  else
+    if (not FIsSkipping) then
+      InternalStatement(FCurrentStatement,FAborted);
+end;
+
+procedure TCustomSQLScript.Execute;
+
+begin
+  FSkipMode:=smNone;
+  FIsSkipping:=False;
+  FSkipStackIndex:=0;
+  Faborted:=False;
+  DefaultDirectives;
+  while not FAborted and Available() do
+    begin
+    NextStatement();
+    ProcessStatement;
+    end;
+end;
+
+function TCustomSQLScript.NextStatement: AnsiString;
+
+var
+  pnt: AnsiString;
+  terminator_found: Boolean;
+
+begin
+  terminator_found:=False;
+  FCurrentStatement.Clear;
+  while FLine <= FSQL.Count do
+    begin
+    pnt:=FindNextSeparator([FTerminator, '/*', '"', '''']);
+    if (pnt=FTerminator) then
+      begin
+      FCol:=FCol + length(pnt);
+      terminator_found:=True;
+      break;
+      end
+    else if pnt = '/*' then
+      begin
+      if FCommentsInSQL then
+        AddToStatement(pnt,false)
+      else
+        FEmitLine:=False;
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['*/']);
+      if FCommentsInSQL then
+        AddToStatement(pnt,false)
+      else
+        FEmitLine:=True;
+      FCol:=FCol + length(pnt);
+      end
+    else if pnt = '"' then
+      begin
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['"']);
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      end
+    else if pnt = '''' then
+      begin
+      AddToStatement(pnt,False);
+      FCol:=FCol + length(pnt);
+      pnt:=FindNextSeparator(['''']);
+      AddToStatement(pnt,false);
+      FCol:=FCol + length(pnt);
+      end;
+    end;
+  if not terminator_found then
+    FCurrentStatement.Clear();
+  while (FCurrentStatement.Count > 0) and (trim(FCurrentStatement.Strings[0]) = '') do
+    FCurrentStatement.Delete(0);
+  Result:=FCurrentStatement.Text;
+end;
+
+Constructor TCustomSQLScript.Create (AnOwner: TComponent);
+
+Var
+  L : TStringList;
+
+begin
+  inherited;
+  L:=TStringList.Create;
+  With L do
+    begin
+    Sorted:=True;
+    Duplicates:=dupIgnore;
+    end;
+  FDefines:=L;  
+  FCommentsInSQL:=True;
+  FTerminator:=';';
+  L:=TStringList.Create();
+  L.OnChange:=@SQLChange;
+  FSQL:=L;
+  FDirectives:=TStringList.Create();
+  FCurrentStatement:=TStringList.Create();
+  FLine:=1;
+  FCol:=1;
+  FEmitLine:=True;
+  FUseCommit := true;
+  FUseDefines := True;
+  FUseSetTerm := True;
+  DefaultDirectives;
+end;
+
+destructor TCustomSQLScript.Destroy;
+begin
+  FreeAndNil(FCurrentStatement);
+  FreeAndNil(FSQL);
+  FreeAndNil(FDirectives);
+  FreeAndNil(FDefines);
+  inherited Destroy;
+end;
+
+procedure TCustomSQLScript.SetDefines(const Value: TStrings);
+begin
+  FDefines.Assign(Value);
+end;
+
+procedure TCustomSQLScript.DefaultDirectives;
+begin
+  With FDirectives do
+    begin
+    if FUseSetTerm then
+      Add('SET TERM');
+    if FUseCommit then
+      Add('COMMIT');
+    if FUseDefines then
+      begin
+      Add('#IFDEF');
+      Add('#IFNDEF');
+      Add('#ELSE');
+      Add('#ENDIF');
+      Add('#DEFINE');
+      Add('#UNDEF');
+      Add('#UNDEFINE');
+      end;
+    end;
+end;
+
+Function TCustomSQLScript.ProcessConditional(Directive: String; Param : String) : Boolean;
+
+  Procedure PushSkipMode;
+
+  begin
+    if FSkipStackIndex=High(FSkipModeStack) then
+      Raise ESQLScript.Create(SErrIfXXXNestingLimitReached);
+    FSkipModeStack[FSkipStackIndex]:=FSkipMode;
+    FIsSkippingStack[FSkipStackIndex]:=FIsSkipping;
+    Inc(FSkipStackIndex);
+  end;
+
+  Procedure PopSkipMode;
+
+  begin
+    if FSkipStackIndex = 0 then
+      Raise ESQLScript.Create(SErrInvalidEndif);
+    Dec(FSkipStackIndex);
+    FSkipMode := FSkipModeStack[FSkipStackIndex];
+    FIsSkipping := FIsSkippingStack[FSkipStackIndex];
+  end;
+
+Var
+  Index : Integer;
+
+begin
+  Result:=True;
+  if (Directive='#DEFINE') then
+    begin
+    if not FIsSkipping then
+      FDefines.Add(Param);
+    end
+  else if (Directive='#UNDEF') or (Directive='#UNDEFINE') then
+    begin
+    if not FIsSkipping then
+      begin
+      Index:=FDefines.IndexOf(Param);
+      if (Index>=0) then
+        FDefines.Delete(Index);
+      end;
+    end
+  else if (Directive='#IFDEF') or (Directive='#IFNDEF') then
+    begin
+    PushSkipMode;
+    if FIsSkipping then
+      begin
+      FSkipMode:=smAll;
+      FIsSkipping:=true;
+      end
+    else
+      begin
+      Index:=FDefines.IndexOf(Param);
+      if ((Directive='#IFDEF') and (Index<0)) or
+         ((Directive='#IFNDEF') and (Index>=0)) then
+        begin
+        FSkipMode:=smIfBranch;
+        FIsSkipping:=true;
+        end
+      else
+        FSkipMode := smElseBranch;
+      end;
+    end
+  else if (Directive='#ELSE') then
+    begin
+    if (FSkipStackIndex=0) then
+      Raise ESQLScript.Create(SErrInvalidElse);
+    if (FSkipMode=smIfBranch) then
+      FIsSkipping:=false
+    else if (FSkipMode=smElseBranch) then
+      FIsSkipping:=true;
+    end
+  else if (Directive='#ENDIF') then
+    PopSkipMode
+  else
+    Result:=False;
+end;
+
+{ TEventSQLScript }
+
+procedure TEventSQLScript.ExecuteStatement(SQLStatement: TStrings;
+  var StopExecution: Boolean);
+begin
+  if assigned (FOnSQLStatement) then
+    FOnSQLStatement (self, SQLStatement, StopExecution);
+end;
+
+procedure TEventSQLScript.ExecuteDirective(Directive, Argument: String;
+  var StopExecution: Boolean);
+begin
+  if assigned (FOnDirective) then
+    FOnDirective (Self, Directive, Argument, StopExecution);
+end;
+
+procedure TEventSQLScript.ExecuteCommit;
+begin
+  if assigned (FOnCommit) then
+    FOnCommit (Self);
+end;
+
+procedure TEventSQLScript.Execute;
+begin
+  if assigned (FBeforeExec) then
+    FBeforeExec (Self);
+  inherited Execute;
+  if assigned (FAfterExec) then
+    FAfterExec (Self);
+end;
+
+end.
+

packages/fcl-db/src/codegen/buildddcg.lpi

@@ -0,0 +1,77 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="6"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="7">
+      <Unit0>
+        <Filename Value="buildddcg.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="buildddcg"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="fpddpopcode.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpddpopcode"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="fpcgcreatedbf.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpcgcreatedbf"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="fpcgdbcoll.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpcgdbcoll"/>
+      </Unit3>
+      <Unit4>
+        <Filename Value="fpcgsqlconst.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpcgsqlconst"/>
+      </Unit4>
+      <Unit5>
+        <Filename Value="fpcgtiopf.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpcgtiopf"/>
+      </Unit5>
+      <Unit6>
+        <Filename Value="fpddcodegen.pp"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="fpddcodegen"/>
+      </Unit6>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <SearchPaths>
+      <UnitOutputDirectory Value="../../units/$(TARGETCPU)-$(TARGETOS)"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>

packages/fcl-db/src/codegen/buildddcg.lpr

@@ -0,0 +1,15 @@
+program buildddcg;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes
+  { you can add units after this }, fpddpopcode, fpcgcreatedbf, fpcgdbcoll,
+  fpcgsqlconst, fpcgtiopf, fpddcodegen;
+
+begin
+end.
+

packages/fcl-db/src/codegen/fpcgtiopf.pp

@@ -23,7 +23,7 @@ uses
   Classes, SysUtils, db, fpddcodegen;
   
 TYpe
-  TClassOption = (caConstructor,caDestructor,caCreateList,caListAddMethod,caListItemsProperty);
+  TClassOption = (caCreateClass,caConstructor,caDestructor,caCreateList,caListAddMethod,caListItemsProperty);
   TClassOptions = Set of TClassOption;
   TVisitorOption = (voRead,voReadList,voCreate,voDelete,voUpdate);
   TVisitorOptions = set of TVisitorOption;
@@ -61,13 +61,16 @@ TYpe
     procedure DeclareObjectvariable(Strings: TStrings;
       const ObjectClassName: String);
   private
+    Function CreateSQLStatement(V: TVisitorOption) : String;
     function GetOpt: TTiOPFCodeOptions;
     procedure WriteCreateVisitor(Strings: TStrings; const ObjectClassName: String);
     procedure WriteDeleteVisitor(Strings: TStrings; const ObjectClassName: String);
     procedure WriteFieldAssign(Strings: TStrings; F: TFieldPropDef);
-    procedure WriteParamAssign(Strings: TStrings; F: TFieldPropDef);
+    procedure WriteAssignToParam(Strings: TStrings; F: TFieldPropDef);
     procedure WriteReadListVisitor(Strings: TStrings; const ObjectClassName: String);
     procedure WriteReadVisitor(Strings: TStrings; const ObjectClassName: String );
+    procedure WriteSetSQL(Strings: TStrings; const ASQL: String);
+    procedure WriteSQLConstants(Strings: TStrings);
     procedure WriteUpdateVisitor(Strings: TStrings; const ObjectClassName: String);
     procedure WriteVisitorDeclaration(Strings: TStrings; V: TVisitorOption; const ObjectClassName: String);
     procedure WriteVisitorImplementation(Strings: TStrings; V: TVisitorOption; const ObjectClassName: String);
@@ -75,6 +78,7 @@ TYpe
     // Not to be overridden.
     procedure WriteListAddObject(Strings: TStrings; const ListClassName, ObjectClassName: String);
     // Overrides of parent objects
+    function AllowPropertyDeclaration(F: TFieldPropDef; AVisibility: TVisibilities): Boolean; override;
     Function GetInterfaceUsesClause : string; override;
     Procedure DoGenerateInterface(Strings: TStrings); override;
     Procedure DoGenerateImplementation(Strings: TStrings); override;
@@ -92,6 +96,9 @@ TYpe
     Property TiOPFOptions : TTiOPFCodeOptions Read GetOpt;
   end;
 
+Const
+  SOID = 'OID'; // OID property.
+  
 implementation
 
 { TTiOPFCodeOptions }
@@ -118,7 +125,7 @@ end;
 constructor TTiOPFCodeOptions.Create;
 begin
   inherited Create;
-  FListAncestorName:='TObjectList';
+  FListAncestorName:='TTiObjectList';
   AncestorClass:='TTiObject';
   ObjectClassName:='MyObject';
   FVisitorOptions:=[voRead,voCreate,voDelete,voUpdate];
@@ -179,7 +186,7 @@ begin
   Result:=inherited GetInterfaceUsesClause;
   If (Result<>'') then
     Result:=Result+',';
-  Result:=Result+'tiVisitor, tiObject';
+  Result:=Result+'tiVisitor, tiVisitorDB, tiObject';
 end;
 
 procedure TTiOPFCodeGenerator.DoGenerateInterface(Strings: TStrings);
@@ -188,7 +195,13 @@ Var
   V : TVisitorOption;
 
 begin
-  inherited DoGenerateInterface(Strings);
+  If (caCreateClass in TiOPFOptions.ClassOptions) then
+    inherited DoGenerateInterface(Strings)
+  else
+    begin
+    Addln(Strings,'Type');
+    Addln(Strings);
+    end;
   With TiOPFOptions do
     begin
     IncIndent;
@@ -247,6 +260,110 @@ begin
   AddlN(Strings);
 end;
 
+Function TTiOPFCodeGenerator.CreateSQLStatement(V : TVisitorOption) : String;
+
+  Function AddToS(Const S,Add : String) : string;
+  
+  begin
+    Result:=S;
+    If (Result<>'') then
+      Result:=Result+', ';
+    Result:=Result+Add;
+  end;
+
+Var
+  I : integer;
+  W,S,VS,TN : String;
+  F : TFieldPropDef;
+
+begin
+  TN:='MyTable';
+  S:='';
+  VS:='';
+  W:='Your condition here';
+  Result:='';
+  Case V of
+   voRead,
+   voReadList : begin
+                Result:='SELECT ';
+                For I:=0 to Fields.Count-1 do
+                  begin
+                  F:=Fields[i];
+                  If F.Enabled then
+                    begin
+                    S:=AddToS(S,F.FieldName);
+                    If (V=voRead) and (F.PropertyName=SOID) then
+                      W:=Format('%s = :%s',[F.FieldName,F.FieldName]);
+                    end;
+                  end;
+                Result:=Result+S+Format(' FROM %s WHERE (%s);',[TN,W]);
+                end;
+   voCreate : begin
+              Result:=Format('INSERT INTO %s (',[TN]);
+              For I:=0 to Fields.Count-1 do
+                begin
+                F:=Fields[i];
+                If F.Enabled then
+                  begin
+                  S:=AddToS(S,F.FieldName);
+                  VS:=AddToS(VS,':'+F.FieldName);
+                  end;
+                end;
+              Result:=Result+S+') VALUES ('+VS+');';
+              end;
+   voDelete : begin
+              For I:=0 to Fields.Count-1 do
+                begin
+                F:=Fields[i];
+                If (F.PropertyName=SOID) then
+                  W:=Format('%s = :%s',[F.FieldName,F.FieldName]);
+                end;
+              Result:=Format('DELETE FROM %s WHERE (%s);',[TN,W]);
+              end;
+   voUpdate : begin
+              Result:=Format('UPDATE %s SET ',[TN]);
+              For I:=0 to Fields.Count-1 do
+                 begin
+                  F:=Fields[i];
+                  If F.Enabled then
+                    If (F.PropertyName=SOID) then
+                      W:=Format('%s = :%s',[F.FieldName,F.FieldName])
+                    else
+                      S:=AddToS(S,F.FieldName+' = :'+F.FieldName);
+                  end;
+              Result:=Result+S+Format(' WHERE (%s);',[W]);
+              end;
+  end;
+end;
+
+procedure TTiOPFCodeGenerator.WriteSQLConstants(Strings : TStrings);
+
+Const
+  VisSQL : Array [TVisitorOption] of string
+         = ('Read','ReadList','Create','Delete','Update');
+
+Var
+  OCN,S : String;
+  V : TVisitorOption;
+
+begin
+  AddLn(Strings,'Const');
+  IncIndent;
+  try
+    OCN:=StripType(TiOPFOptions.ObjectClassName);
+    For V:=Low(TVisitorOption) to High(TVisitorOption) do
+      If V in TiOPFOptions.VisitorOptions then
+        begin
+        S:=CreateSQLStatement(V);
+        S:=Format('SQL%s%s = ''%s'';',[VisSQL[V],OCN,S]);
+        AddLn(Strings,S);
+        end;
+  finally
+    DecIndent;
+  end;
+  AddLn(Strings,'');
+end;
+
 
 procedure TTiOPFCodeGenerator.DoGenerateImplementation(Strings: TStrings);
 
@@ -254,9 +371,12 @@ Var
   V : TVisitorOption;
 
 begin
-  inherited DoGenerateImplementation(Strings);
+  If (caCreateClass in TiOPFOptions.ClassOptions) then
+    inherited DoGenerateImplementation(Strings);
   With TiOPFOptions do
     begin
+    If (VisitorOptions<>[])   then
+      WriteSQLConstants(Strings);
     If caCreateList in ClassOptions then
       CreateListImplementation(Strings,ObjectClassName,ListClassName);
     For V:=Low(TVisitorOption) to High(TVisitorOption) do
@@ -308,9 +428,9 @@ begin
   If DeclareObject Then
     DeclareObjectVariable(Strings,ObjectClassName);
   AddLn(Strings,'begin');
+  IncIndent;
   If DeclareObject Then
     Addln(Strings,'O:=%s(Visited);',[ObjectClassName]);
-  IncIndent;
 end;
 
 Procedure TTiOPFCodeGenerator.DeclareObjectvariable(Strings : TStrings; Const ObjectClassName : String);
@@ -343,16 +463,19 @@ end;
 procedure TTiOPFCodeGenerator.WriteReadVisitor(Strings : TStrings; Const ObjectClassName : String);
 
 Var
-  C,S : String;
+  OCN,CS,C,S : String;
   I : Integer;
+  F : TFieldPropDef;
 
 begin
-  C:=Format('TRead%sVisitor',[StripType(ObjectClassName)]);
+  OCN:=StripType(ObjectClassName);
+  CS:=Format('SQLRead%s',[OCN]);
+  C:=Format('TRead%sVisitor',[OCN]);
   Addln(Strings,'{ %s }',[C]);
   Addln(Strings);
   // Init
   S:=BeginInit(Strings,C);
-  Addln(Strings,'Query.SQL.Text:=SQLReadList;');
+  WriteSetSQL(Strings,CS);
   DecIndent;
   EndMethod(Strings,S);
   // AcceptVisitor
@@ -360,12 +483,17 @@ begin
   DecIndent;
   EndMethod(Strings,S);
   // AcceptSetupParams
-  S:=BeginSetupParams(Strings,C,'',False);
-  AddLn(Strings,'// Set up as needed');
+  F:=Fields.FindPropName('OID');
+  S:=BeginSetupParams(Strings,C,ObjectClassName,F<>Nil);
+  If (F<>Nil) then
+    WriteAssignToParam(Strings,F)
+  else
+    AddLn(Strings,'// Set up as needed');
   DecIndent;
   EndMethod(Strings,S);
   // MapRowToObject
   S:=BeginMapRowToObject(Strings,C,ObjectClassName);
+  Addln(Strings,'O:=%s(Visited);',[ObjectClassName]);
   Addln(Strings,'With Query do',[ObjectClassName]);
   IncINdent;
   try
@@ -373,7 +501,7 @@ begin
     For I:=0 to Fields.Count-1 do
       If Fields[i].Enabled then
         WriteFieldAssign(Strings,Fields[i]);
-    Addln(Strings,'end');
+    Addln(Strings,'end;');
   finally
     DecIndent;
   end;
@@ -390,43 +518,46 @@ begin
   PN:=F.PropertyName;
   FN:=F.FieldName;
   SFN:=CreateString(FN);
-  Case F.PropertyType of
-    ptBoolean :
-      S:='AsBoolean';
-    ptShortint, ptByte,
-    ptSmallInt, ptWord,
-    ptLongint, ptCardinal :
-      S:='AsInteger';
-    ptInt64, ptQWord:
-      If F.FieldType=ftLargeInt then
-        R:=Format('O.%s:=(FieldByName(%s) as TLargeIntField).AsLargeInt;',[PN,SFN])
-      else
+  If (PN=SOID) then
+    R:=Format('O.OID.AssignFromTIQuery(''%s'',Query);',[FN])
+  else
+    Case F.PropertyType of
+      ptBoolean :
+        S:='AsBoolean';
+      ptShortint, ptByte,
+      ptSmallInt, ptWord,
+      ptLongint, ptCardinal :
         S:='AsInteger';
-    ptShortString, ptAnsiString, ptWideString :
-      S:='AsString';
-    ptSingle, ptDouble, ptExtended, ptComp :
-      S:='AsFloat';
-    ptCurrency :
-      S:='AsCurrency';
-    ptDateTime :
-      S:='AsDateTime';
-    ptEnumerated :
-      R:=Format('Integer(O.%s):=FieldAsInteger[%s];',[PN,SFN]);
-    ptSet :
-      S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
-    ptStream :
-      R:=Format('FieldByName(%s).SaveToStream(O.%s);',[SFN,PN]);
-    ptTStrings :
-      R:=Format('O.%s.Text:=FieldAsString[%s];',[PN,SFN]);
-    ptCustom :
-      R:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
-  end;
+      ptInt64, ptQWord:
+        If F.FieldType=ftLargeInt then
+          R:=Format('O.%s:=(FieldByName(%s) as TLargeIntField).AsLargeInt;',[PN,SFN])
+        else
+          S:='AsInteger';
+      ptShortString, ptAnsiString, ptWideString :
+        S:='AsString';
+      ptSingle, ptDouble, ptExtended, ptComp :
+        S:='AsFloat';
+      ptCurrency :
+        S:='AsCurrency';
+      ptDateTime :
+        S:='AsDateTime';
+      ptEnumerated :
+        R:=Format('Integer(O.%s):=FieldAsInteger[%s];',[PN,SFN]);
+      ptSet :
+        S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
+      ptStream :
+        R:=Format('FieldByName(%s).SaveToStream(O.%s);',[SFN,PN]);
+      ptTStrings :
+        R:=Format('O.%s.Text:=FieldAsString[%s];',[PN,SFN]);
+      ptCustom :
+        R:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
+    end;
   If (S<>'') then
     R:=Format('O.%s:=Field%s[%s];',[PN,S,SFN]);
   AddLn(Strings,R);
 end;
 
-procedure TTiOPFCodeGenerator.WriteParamAssign(Strings : TStrings; F : TFieldPropDef);
+procedure TTiOPFCodeGenerator.WriteAssignToParam(Strings : TStrings; F : TFieldPropDef);
 
 Var
   PN,FN,SFN,R,S : String;
@@ -435,39 +566,42 @@ begin
   PN:=F.PropertyName;
   FN:=F.FieldName;
   SFN:=CreateString(FN);
-  Case F.PropertyType of
-    ptBoolean :
-      S:='AsBoolean';
-    ptShortint, ptByte,
-    ptSmallInt, ptWord,
-    ptLongint, ptCardinal :
-      S:='AsInteger';
-    ptInt64, ptQWord:
-      If F.FieldType=ftLargeInt then
-        R:=Format('O.%s:=(Name(%s) as TLargeIntField).AsLargeInt;',[PN,SFN])
-      else
+  If (PN=SOID) then
+    R:=Format('O.OID.AssignToTIQuery(''%s'',Query);',[FN])
+  else
+    Case F.PropertyType of
+      ptBoolean :
+        S:='AsBoolean';
+      ptShortint, ptByte,
+      ptSmallInt, ptWord,
+      ptLongint, ptCardinal :
         S:='AsInteger';
-    ptShortString, ptAnsiString, ptWideString :
-      S:='AsString';
-    ptSingle, ptDouble, ptExtended, ptComp :
-      S:='AsFloat';
-    ptCurrency :
-      S:='AsCurrency';
-    ptDateTime :
-      S:='AsDateTime';
-    ptEnumerated :
-      R:=Format('ParamAsInteger[%s]:=Integer(O.%s);',[SFN,PN]);
-    ptSet :
-      S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
-    ptStream :
-      R:=Format('AssignParamFromStream(%s,%s);',[SFN,PN]);
-    ptTStrings :
-      R:=Format('ParamAsString[%s]:=O.%s.Text;',[SFN,PN]);
-    ptCustom :
-      R:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
-  end;
+      ptInt64, ptQWord:
+        If F.FieldType=ftLargeInt then
+          R:=Format('O.%s:=(Name(%s) as TLargeIntField).AsLargeInt;',[PN,SFN])
+        else
+          S:='AsInteger';
+      ptShortString, ptAnsiString, ptWideString :
+        S:='AsString';
+      ptSingle, ptDouble, ptExtended, ptComp :
+        S:='AsFloat';
+      ptCurrency :
+        S:='AsCurrency';
+      ptDateTime :
+        S:='AsDateTime';
+      ptEnumerated :
+        R:=Format('ParamAsInteger[%s]:=Integer(O.%s);',[SFN,PN]);
+      ptSet :
+        S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
+      ptStream :
+        R:=Format('AssignParamFromStream(%s,%s);',[SFN,PN]);
+      ptTStrings :
+        R:=Format('ParamAsString[%s]:=O.%s.Text;',[SFN,PN]);
+      ptCustom :
+        R:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
+    end;
   If (S<>'') then
-    R:=Format('O.%s:=Param%s[%s];',[PN,S,SFN]);
+    R:=Format('Param%s[%s]:=O.%s;',[S,SFN,PN]);
   AddLn(Strings,R);
 end;
 
@@ -478,17 +612,19 @@ end;
 procedure TTiOPFCodeGenerator.WriteReadListVisitor(Strings : TStrings; Const ObjectClassName : String);
 
 Var
-  C,S,LN : String;
+  OCN,CS,C,S,LN : String;
   I : Integer;
 
 begin
   LN:=tiOPFOptions.ListClassName;
-  C:=Format('TRead%sVisitor',[StripType(LN)]);
+  OCN:=StripType(ObjectClassName);
+  CS:=Format('SQLReadList%s',[OCN]);
+  C:=Format('TReadList%sVisitor',[StripType(OCN)]);
   Addln(Strings,'{ %s }',[C]);
   Addln(Strings);
   // Init
   S:=BeginInit(Strings,C);
-  Addln(Strings,'Query.SQL.Text:=SQLReadList;');
+  WriteSetSQL(Strings,CS);
   DecIndent;
   EndMethod(Strings,C);
   // AcceptVisitor
@@ -500,11 +636,19 @@ begin
   DecIndent;
   EndMethod(Strings,S);
   // MapRowToObject
-  S:=BeginMapRowToObject(Strings,S,ObjectClassName);
+  S:=BeginMapRowToObject(Strings,C,ObjectClassName);
   Addln(Strings,'O:=%s.Create;',[ObjectClassName]);
-  For I:=0 to Fields.Count-1 do
-    If Fields[i].Enabled then
-      WriteFieldAssign(Strings,Fields[i]);
+  Addln(Strings,'With Query do',[ObjectClassName]);
+  IncINdent;
+  try
+    Addln(Strings,'begin');
+    For I:=0 to Fields.Count-1 do
+      If Fields[i].Enabled then
+        WriteFieldAssign(Strings,Fields[i]);
+    Addln(Strings,'end;');
+  finally
+    DecIndent;
+  end;
   Addln(Strings,'O.ObjectState:=posClean;');
   Addln(Strings,'%s(Visited).Add(O);',[LN]);
   DecIndent;
@@ -519,16 +663,18 @@ procedure TTiOPFCodeGenerator.WriteCreateVisitor(Strings : TStrings; Const Objec
 
 
 Var
-  C,S : String;
+  OCN,CS,C,S : String;
   I : Integer;
 
 begin
-  C:=Format('TCreate%sVisitor',[StripType(ObjectClassName)]);
+  OCN:=StripType(ObjectClassName);
+  CS:=Format('SQLCreate%s',[OCN]);
+  C:=Format('TCreate%sVisitor',[OCN]);
   Addln(Strings,'{ %s }',[C]);
   Addln(Strings);
   // Init
   S:=BeginInit(Strings,C);
-  Addln(Strings,'Query.SQL.Text:=SQLCreateObject;');
+  WriteSetSQL(Strings,CS);
   DecIndent;
   EndMethod(Strings,S);
   // AcceptVisitor
@@ -544,7 +690,7 @@ begin
     Addln(Strings,'begin');
     For I:=0 to Fields.Count-1 do
       If Fields[i].Enabled then
-        WriteParamAssign(Strings,Fields[i]);
+        WriteAssignToParam(Strings,Fields[i]);
     Addln(Strings,'end;');
   finally
     DecIndent;
@@ -553,17 +699,26 @@ begin
   EndMethod(Strings,S);
 end;
 
+procedure TTiOPFCodeGenerator.WriteSetSQL(Strings : TStrings; Const ASQL : String);
+
+begin
+  Addln(Strings,Format('Query.SQL.Text:=%s;',[ASQL]));
+end;
+
 procedure TTiOPFCodeGenerator.WriteDeleteVisitor(Strings : TStrings; Const ObjectClassName : String);
 
 Var
-  C,S : String;
-
+  OCN,CS, C,S : String;
+  F : TFieldPropDef;
+  
 begin
+  OCN:=StripType(ObjectClassName);
+  CS:=Format('SQLDelete%s',[OCN]);
   C:=Format('TDelete%sVisitor',[StripType(ObjectClassName)]);
   Addln(Strings,'{ %s }',[C]);
   // Init
   S:=BeginInit(Strings,C);
-  Addln(Strings,'Query.SQL.Text:=SQLDeleteObject;');
+  WriteSetSQL(Strings,CS);
   DecIndent;
   EndMethod(Strings,S);
   // AcceptVisitor
@@ -573,7 +728,11 @@ begin
   EndMethod(Strings,S);
   // SetupParams
   S:=BeginSetupParams(Strings,C,ObjectClassName,True);
-  AddLn(Strings,'// Add parameter setup code here ');
+  F:=Fields.FindPropName('OID');
+  If (F<>Nil) then
+    WriteAssignToParam(Strings,F)
+  else
+    AddLn(Strings,'// Add parameter setup code here ');
   DecIndent;
   EndMethod(Strings,S);
 end;
@@ -581,16 +740,18 @@ end;
 procedure TTiOPFCodeGenerator.WriteUpdateVisitor(Strings : TStrings; Const ObjectClassName : String);
 
 Var
-  C,S : String;
+  OCN,CS,C,S : String;
   I : Integer;
 
 begin
-  C:=Format('TUpdate%sVisitor',[StripType(ObjectClassName)]);
+  OCN:=StripType(ObjectClassName);
+  CS:=Format('SQLUpdate%s',[OCN]);
+  C:=Format('TUpdate%sVisitor',[OCN]);
   Addln(Strings,'{ %s }',[C]);
   Addln(Strings);
   // Init
   S:=BeginInit(Strings,C);
-  Addln(Strings,'Query.SQL.Text:=SQLUpdateObject;');
+  WriteSetSQl(Strings,CS);
   DecIndent;
   EndMethod(Strings,S);
   // AcceptVisitor
@@ -606,7 +767,7 @@ begin
     Addln(Strings,'begin');
     For I:=0 to Fields.Count-1 do
       If Fields[i].Enabled then
-        WriteParamAssign(Strings,Fields[i]);
+        WriteAssignToParam(Strings,Fields[i]);
     Addln(Strings,'end;');
   finally
     DecIndent;
@@ -630,8 +791,8 @@ begin
     AddLn(Strings,'Private');
     IncIndent;
     Try
-      AddLn(Strings,'Function GetObj(Index : Integer) : %s;',[ObjectClassname]);
-      AddLn(Strings,'Procedure SetObj(Index : Integer; AValue : %s);',[ObjectClassname]);
+      AddLn(Strings,'Function GetObj(AIndex : Integer) : %s;',[ObjectClassname]);
+      AddLn(Strings,'Procedure SetObj(AIndex : Integer; AValue : %s);',[ObjectClassname]);
     Finally
       DecIndent;
     end;
@@ -641,7 +802,7 @@ begin
     AddLn(Strings,'Public');
     IncIndent;
     Try
-      Addln(Strings,'Procedure Add(AnItem : %s); reintroduce;',[ObjectClassName]);
+      Addln(Strings,'Function Add(AnItem : %s) : Integer; reintroduce;',[ObjectClassName]);
     Finally
       DecIndent;
     end;
@@ -668,6 +829,7 @@ begin
   Addln(Strings,'%s = Class(%s)',[ListClassName,ListAncestorName]);
   DoCreateListDeclaration(Strings,ObjectClassName,ListClassName,ListAncestorName);
   AddLn(Strings,'end;');
+  Addln(Strings);
 end;
 
 procedure TTiOPFCodeGenerator.WriteListAddObject(Strings: TStrings;
@@ -677,16 +839,26 @@ Var
   S : String;
   
 begin
-   S:=Format('Procedure %s.Add(AnItem : %s);',[ListClassName,ObjectClassName]);
+   S:=Format('Function %s.Add(AnItem : %s) : Integer;',[ListClassName,ObjectClassName]);
    BeginMethod(Strings,S);
    Addln(Strings,'begin');
    IncIndent;
    try
-     Addln(Strings,'inherited Add(AnItem);');
+     Addln(Strings,'Result:=inherited Add(AnItem);');
    finally
      DecIndent;
    end;
    EndMethod(Strings,S);
+   Addln(Strings);
+end;
+
+function TTiOPFCodeGenerator.AllowPropertyDeclaration(F: TFieldPropDef;
+  AVisibility: TVisibilities): Boolean;
+begin
+  If F.PropertyName=SOID then
+    Result:=False
+  else
+    Result:=inherited AllowPropertyDeclaration(F, AVisibility);
 end;
 
 
@@ -700,27 +872,31 @@ begin
     begin
     AddLn(Strings,'{ %s }',[ListClassName]);
     AddLn(Strings);
-    S:=Format('Function %s.GetObj(Index : Integer) : %s;',[ListClassName,ObjectClassname]);
+    S:=Format('Function %s.GetObj(AIndex : Integer) : %s;',[ListClassName,ObjectClassname]);
     BeginMethod(Strings,S);
     AddLn(Strings,'begin');
     IncIndent;
     try
-      AddLn(Strings,'Result:=%s(Inherited Items[Index]);',[ObjectClassname]);
+      AddLn(Strings,'Result:=%s(Inherited Items[AIndex]);',[ObjectClassname]);
     finally
       DecIndent;
     end;
     EndMethod(Strings,S);
-    S:=Format('Procedure %s.SetObj(Index : Integer; AValue : %s);',[ListClassName,ObjectClassname]);
+    Addln(Strings);
+    S:=Format('Procedure %s.SetObj(AIndex : Integer; AValue : %s);',[ListClassName,ObjectClassname]);
     BeginMethod(Strings,S);
     AddLn(Strings,'begin');
     IncIndent;
     try
-      AddLn(Strings,'Inherited Items[Index]:=AValue;');
+      AddLn(Strings,'Inherited Items[AIndex]:=AValue;');
     finally
       DecIndent;
     end;
     EndMethod(Strings,S);
+    Addln(Strings);
     end;
+  If (caListAddMethod in tiOPFOptions.ClassOptions) then
+    WriteListAddObject(Strings,ListClassName,ObjectClassName);
 end;
 
 Initialization

packages/fcl-db/src/codegen/fpddcodegen.pp

@@ -36,6 +36,7 @@ Type
                ptCustom);
                
   TVisibility = (vPrivate,vProtected,vPublic,vPublished);
+  TVisibilities = Set of TVisibility;
   TPropAccess = (paReadWrite,paReadonly,paWriteonly);
 
 
@@ -108,8 +109,12 @@ Type
 
   TCodeGeneratorOptions = Class(TPersistent)
   private
+    FImplementationUnits: String;
+    FInterfaceUnits: String;
     FOptions: TCodeOptions;
     FUnitName: String;
+    procedure SetImplementationUnits(const AValue: String);
+    procedure SetInterfaceUnits(const AValue: String);
     procedure SetUnitname(const AValue: String);
   Protected
     procedure SetOPtions(const AValue: TCodeOptions); virtual;
@@ -119,6 +124,8 @@ Type
   Published
     Property Options : TCodeOptions Read FOptions Write SetOPtions;
     Property UnitName : String Read FUnitName Write SetUnitname;
+    Property InterfaceUnits : String Read FInterfaceUnits Write SetInterfaceUnits;
+    Property ImplementationUnits : String Read FImplementationUnits Write SetImplementationUnits;
   end;
   TCodeGeneratorOptionsClass = Class of TCodeGeneratorOptions;
 
@@ -230,7 +237,9 @@ Type
     procedure CreateClassEnd(Strings : TStrings); virtual;
     // Called right after section start is written.
     procedure WriteVisibilityStart(V: TVisibility; Strings: TStrings); virtual;
-    // Writes a property declaration.
+    // Should a property declaration be written ?
+    function AllowPropertyDeclaration(F: TFieldPropDef; AVisibility: TVisibilities): Boolean; virtual;
+    // Creates a property declaration.
     Function PropertyDeclaration(Strings: TStrings; Def: TFieldPropDef) : String; virtual;
     // Writes private fields for class.
     procedure WritePrivateFields(Strings: TStrings); virtual;
@@ -727,6 +736,12 @@ begin
   end;
 end;
 
+Function TDDClassCodeGenerator.AllowPropertyDeclaration(F : TFieldPropDef; AVisibility : TVisibilities) : Boolean;
+
+begin
+  Result:=Assigned(f) and F.Enabled and ((AVisibility=[]) or (F.PropertyVisibility in AVisibility));
+end;
+
 Procedure TDDClassCodeGenerator.CreateDeclaration(Strings : TStrings);
 
 Const
@@ -751,7 +766,7 @@ begin
       For I:=0 to Fields.Count-1 do
         begin
         F:=Fields[i];
-        if F.Enabled and (F.PropertyVisibility=v) then
+        if AllowPropertyDeclaration(F,[V]) then
           AddLn(Strings,PropertyDeclaration(Strings,F)+';');
         end;
     Finally
@@ -773,7 +788,7 @@ begin
     For I:=0 to Fields.Count-1 do
       begin
       F:=Fields[i];
-      if F.Enabled then
+      if AllowPropertyDeclaration(F,[]) then
         AddLn(Strings,'F%s : %s;',[F.PropertyName,F.ObjPasTypeDef]);
       end;
   Finally
@@ -802,7 +817,7 @@ begin
   For I:=0 to Fields.Count-1 do
     begin
     F:=Fields[i];
-    if F.Enabled and F.HasGetter then
+    if AllowPropertyDeclaration(F,[]) and F.HasGetter then
       begin
       If not B then
         begin
@@ -817,7 +832,7 @@ begin
   For I:=0 to Fields.Count-1 do
     begin
     F:=Fields[i];
-    if F.Enabled and F.HasGetter then
+    if AllowPropertyDeclaration(F,[]) and F.HasGetter then
       begin
       If not B then
         begin
@@ -1028,11 +1043,11 @@ begin
     For I:=0 to Fields.Count-1 do
       begin
       F:=Fields[i];
-      If F.Enabled then
+      If AllowPropertyDeclaration(F,[]) then
         begin
         if (F.Hasgetter) then
           AddLn(Strings,PropertyGetterDeclaration(F,False));
-        if (Fields[i].HasSetter) then
+        if (F.HasSetter) then
           AddLn(Strings,PropertySetterDeclaration(F,False));
         end;
       end;
@@ -1217,11 +1232,13 @@ end;
 function TDDCustomCodeGenerator.GetInterfaceUsesClause: String;
 begin
   Result:='Classes, SysUtils';
+  If (CodeOptions.InterfaceUnits<>'') then
+    Result:=Result+','+CodeOptions.InterfaceUnits;
 end;
 
 function TDDCustomCodeGenerator.GetImplementationUsesClause: String;
 begin
-  Result:='';
+  Result:=CodeOptions.ImplementationUnits;
 end;
 
 procedure TDDCustomCodeGenerator.GenerateCode(Stream: TStream);
@@ -1473,6 +1490,19 @@ begin
   FUnitName:=AValue;
 end;
 
+procedure TCodeGeneratorOptions.SetInterfaceUnits(const AValue: String);
+begin
+  if FInterfaceUnits=AValue then exit;
+  FInterfaceUnits:=AValue;
+  // Do some checks here
+end;
+
+procedure TCodeGeneratorOptions.SetImplementationUnits(const AValue: String);
+begin
+  if FImplementationUnits=AValue then exit;
+  FImplementationUnits:=AValue;
+end;
+
 { TClassCodeGeneratorOptions }
 
 procedure TClassCodeGeneratorOptions.SetClassName(const AValue: String);

packages/fcl-db/src/codegen/fpddpopcode.pp

@@ -0,0 +1,389 @@
+unit fpddpopcode;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, typinfo, fpdatadict, db;
+
+Type
+  TDDCodeGenOption = (dcoFields,dcoIndexes,dcoProcedurePerTable,dcoUseWith,dcoClassDecl);
+  TDDCodeGenOptions = Set of TDDCodeGenoption;
+  
+  { TFPDDPopulateCodeGenerator }
+
+  TFPDDPopulateCodeGenerator = Class(TComponent)
+  private
+    FClassName: String;
+    FDD: TFPDataDictionary;
+    FDDV: String;
+    FIndent: Integer;
+    FCurrentIndent: Integer;
+    FOptions: TDDCodeGenOptions;
+    FTables: TStrings;
+    FProcedures : TStrings;
+    procedure SetOptions(const AValue: TDDCodeGenOptions);
+    procedure SetTables(const AValue: TStrings);
+  Protected
+    // General code generating routines
+    procedure AddProperty(const ObjName, PropName, PropValue: String; Lines: TStrings);
+    procedure AddProperty(const ObjName, PropName: String; PropValue: Boolean; Lines: TStrings);
+    procedure AddStringProperty(const ObjName, PropName, PropValue: String;  Lines: TStrings);
+    procedure AddProcedure(AProcedureName: String; Lines: TStrings); virtual;
+    procedure EndProcedure(Lines: TStrings);
+    Procedure Indent;
+    Procedure Undent;
+    procedure AddLine(ALine: String; Lines: TStrings); virtual;
+    Function EscapeString(Const S : String) : string;
+    procedure CreateClassDecl(Lines: TStrings); virtual;
+    // Data dictionare specific
+    procedure CheckDatadict;
+    procedure CreateFooter(Lines: TStrings);
+    procedure CreateHeader(Lines: TStrings);
+    // Table code
+    Function DoTable (Const ATable : TDDtableDef) : Boolean; virtual;
+    procedure CreateTableCode(T: TDDTableDef; Lines: TStrings);
+    procedure AddTableVars(Lines: TStrings);
+    procedure DoTableHeader(ATable: TDDTableDef; Lines: TStrings);
+    procedure DoTableFooter(ATable: TDDTableDef; Lines: TStrings);
+    // Field code
+    Function DoField (Const ATable : TDDtableDef; Const AField : TDDFieldDef) : Boolean; virtual;
+    procedure CreateFieldCode(ATable: TDDTableDef; AField: TDDFieldDef;  Lines: TStrings);
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure CreateCode(Lines : TStrings);
+    Property DataDictionary : TFPDataDictionary Read FDD Write FDD;
+  Published
+    Property Options : TDDCodeGenOptions Read FOptions Write SetOptions;
+    Property Tables : TStrings Read FTables Write SetTables;
+    Property IndentSize : Integer Read FIndent Write FIndent;
+    Property DDVarName : String Read FDDV Write FDDV;
+    Property ClassName : String Read FClassName Write FClassName;
+  end;
+  
+implementation
+
+Resourcestring
+  SErrNoDataDictionary = 'Cannot perform this operation without datadictionary';
+  SErrNoDataDictionaryName = 'Cannot perform this operation without datadictionary name';
+  
+
+{ TFPDDPopulateCodeGenerator }
+
+procedure TFPDDPopulateCodeGenerator.SetOptions(const AValue: TDDCodeGenOptions);
+begin
+  if FOptions=AValue then exit;
+  FOptions:=AValue;
+end;
+
+procedure TFPDDPopulateCodeGenerator.SetTables(const AValue: TStrings);
+begin
+  if FTables=AValue then exit;
+  FTables.Assign(AValue);
+end;
+
+function TFPDDPopulateCodeGenerator.DoTable(Const ATable: TDDtableDef): Boolean;
+begin
+  Result:=Assigned(ATable) and ((FTables.Count=0) or (FTables.IndexOf(ATable.TableName)<>-1));
+end;
+
+function TFPDDPopulateCodeGenerator.DoField(const ATable: TDDtableDef;
+  const AField: TDDFieldDef): Boolean;
+begin
+  Result:=Assigned(ATable) and Assigned(AField);
+end;
+
+constructor TFPDDPopulateCodeGenerator.Create(AOwner: TComponent);
+
+Var
+  T : TStringList;
+
+begin
+  inherited Create(AOwner);
+  T:=TStringList.Create;
+  T.Sorted:=true;
+  T.Duplicates:=dupIgnore;
+  FTables:=T;
+  IndentSize:=2;
+end;
+
+destructor TFPDDPopulateCodeGenerator.Destroy;
+begin
+  FreeAndNil(FTables);
+  inherited Destroy;
+end;
+
+procedure TFPDDPopulateCodeGenerator.CheckDatadict;
+
+begin
+  If (FDD=Nil) then
+    Raise EDataDict.Create(SErrNoDataDictionary);
+  If (FDDV='') then
+    Raise EDataDict.Create(SErrNoDataDictionaryName);
+end;
+
+function TFPDDPopulateCodeGenerator.EscapeString(const S: String): string;
+begin
+  Result:=StringReplace(S,'''','''''',[rfReplaceAll]);
+end;
+
+procedure TFPDDPopulateCodeGenerator.AddProcedure(AProcedureName : String; Lines: TStrings);
+
+Var
+  S : String;
+
+begin
+  S:=AProcedureName;
+  FProcedures.Add(S);
+  If (FClassName<>'') then
+    S:=FClassName+'.'+S;
+  AddLine('Procedure '+S+';',Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.EndProcedure(Lines: TStrings);
+
+begin
+  Undent;
+  AddLine('end;',lines);
+  AddLine('',Lines)
+end;
+
+
+procedure TFPDDPopulateCodeGenerator.AddLine(ALine: String; Lines: TStrings);
+begin
+  If (ALine<>'') and (FCurrentIndent<>0) then
+    Aline:=StringOfChar(' ',FCurrentIndent)+ALine;
+  Lines.Add(ALine);
+end;
+
+procedure TFPDDPopulateCodeGenerator.Indent;
+begin
+  Inc(FCurrentIndent,FIndent);
+end;
+
+procedure TFPDDPopulateCodeGenerator.Undent;
+begin
+  Dec(FCurrentIndent,FIndent);
+  If (FCurrentIndent<0) then
+    FCurrentIndent:=0;
+end;
+
+procedure TFPDDPopulateCodeGenerator.AddTableVars(Lines: TStrings);
+
+begin
+  AddLine('',Lines);
+  AddLine('Var',Lines);
+  Indent;
+  AddLine('T : TDDTableDef;',lines);
+  If dcoFields in Options then
+    AddLine('F : TDDFieldDef;',lines);
+  Undent;
+end;
+
+
+procedure TFPDDPopulateCodeGenerator.DoTableHeader(ATable : TDDTableDef; Lines: TStrings);
+
+begin
+  If dcoProcedurePerTable in Options then
+    begin
+    AddProcedure('PopulateTable'+ATable.TableName,Lines);
+    AddTableVars(Lines);
+    AddLine('',Lines);
+    AddLine('begin',Lines);
+    Indent;
+    end;
+  AddLine(Format('T:=%s.Tables.AddTable(''%s'');',[FDDV,ATable.TableName]),Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.DoTableFooter(ATable : TDDTableDef; Lines: TStrings);
+
+begin
+  If dcoProcedurePerTable in Options then
+    EndProcedure(Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.AddProperty(Const ObjName,PropName : String; PropValue : Boolean; Lines: TStrings);
+
+begin
+  If PropValue then
+    AddProperty(ObjName,PropName,'True',Lines)
+  else
+    AddProperty(ObjName,PropName,'False',Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.AddProperty(Const ObjName,PropName,PropValue : String; Lines: TStrings);
+
+begin
+  If Not (dcoUseWith in Options) then
+    AddLine(Format('%s.%s:=%s;',[Objname,Propname,PropValue]),lines)
+  else
+    AddLine(Format('%s:=%s;',[Propname,PropValue]),lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.AddStringProperty(Const ObjName,PropName,PropValue : String; Lines: TStrings);
+
+begin
+  If (PropValue<>'') then
+    If Not (dcoUseWith in Options) then
+      AddLine(Format('%s.%s:=''%s'';',[Objname,Propname,EscapeString(PropValue)]),lines)
+    else
+      AddLine(Format('%s:=''%s'';',[Propname,EscapeString(PropValue)]),lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateFieldCode(ATable : TDDTableDef; AField : TDDFieldDef; Lines: TStrings);
+
+begin
+  AddLine(Format('F:=T.Fields.AddField(''%s'');',[AField.FieldName]),Lines);
+  If (dcoUseWith in Options) then
+     begin
+     AddLine('With F do',Lines);
+     Indent;
+     AddLine('begin',Lines);
+     end;
+  if (AField.FieldType<>ftUnknown) then
+    AddProperty('F','FieldType',GetEnumName(TypeInfo(TFieldType),Ord(AField.FieldType)),Lines);
+  If (AField.AlignMent<>taLeftJustify) then
+    AddProperty('F','AlignMent',GetEnumName(TypeInfo(TAlignMent),Ord(AField.AlignMent)),Lines);
+  AddStringProperty('F','CustomConstraint',AField.CustomConstraint,Lines);
+  AddStringProperty('F','ConstraintErrorMessage',AField.ConstraintErrorMessage,Lines);
+  AddStringProperty('F','DBDefault',AField.DBDefault,Lines);
+  AddStringProperty('F','DefaultExpression',AField.DefaultExpression,Lines);
+  AddStringProperty('F','DisplayLabel',AField.DisplayLabel,Lines);
+  If (AField.DisplayWidth<>0) then
+    AddProperty('F','DisplayWidth',IntToStr(AField.DisplayWidth),Lines);
+  AddStringProperty('F','Constraint',AField.Constraint,Lines);
+  AddProperty('F','ReadOnly',AField.ReadOnly,Lines);
+  AddProperty('F','Required',AField.Required,Lines);
+  AddProperty('F','Visible',AField.Visible,Lines);
+  If (AField.Size<>0) then
+    AddProperty('F','Size',IntToStr(AField.Size),Lines);
+  If (AField.Precision<>0) then
+    AddProperty('F','Precision',IntToStr(AField.Precision),Lines);
+  AddStringProperty('F','Hint',AField.Hint,Lines);
+  If (dcoUseWith in Options) then
+     begin
+     AddLine('end;',Lines);
+     Undent;
+     end;
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateHeader(Lines: TStrings);
+
+begin
+  If Not (dcoProcedurePerTable in Options) then
+    begin
+    AddProcedure('PopulateDataDictionary',Lines);
+    AddTableVars(Lines);
+    AddLine('',Lines);
+    AddLine('begin',Lines);
+    Indent;
+    end
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateFooter(Lines: TStrings);
+
+Var
+  i : integer;
+  L : TStrings;
+
+begin
+  If (dcoProcedurePerTable in Options) then
+    begin
+    L:=TStringList.Create;
+    try
+      L.Assign(FProcedures);
+      AddProcedure('PopulateDataDictionary',Lines);
+      AddLine('',Lines);
+      AddLine('begin',Lines);
+      Indent;
+      For I:=0 to L.Count-1 do
+        begin
+        AddLine(L[i]+';',Lines);
+        end;
+    finally
+      L.Free;
+    end;
+    end;
+  Undent;
+  EndProcedure(Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateTableCode(T : TDDTableDef; Lines: TStrings);
+
+Var
+  I : Integer;
+  F : TDDFieldDef;
+  
+begin
+  DoTableHeader(T,Lines);
+  try
+    If dcoFields in Options then
+      For I:=0 to T.Fields.Count-1 Do
+        begin
+        F:=T.Fields[I];
+        If DoField(T,F) then
+          CreateFieldcode(T,F,Lines);
+        end;
+  Finally
+    DoTableFooter(T,Lines);
+  end;
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateClassDecl(Lines: TStrings);
+
+Var
+  I : integer;
+
+begin
+  AddLine('(*',Lines);
+  Indent;
+  AddLine(Format('%s = Class(TObject)',[ClassName]),Lines);
+  AddLine('Private',lines);
+  Indent;
+  AddLine(Format('F%s : TFPDataDictionary;',[FDDV]),Lines);
+  Undent;
+  AddLine('Public',Lines);
+  Indent;
+  For I:=0 to FProcedures.Count-1 do
+    AddLine(Format('Procedure %s;',[FProcedures[i]]),Lines);
+  AddLine(Format('Property %s : TFPDataDictionary Read F%:0s Write F%:0s;',[FDDV]),Lines);
+  Undent;
+  AddLine('end;',lines);
+  Undent;
+  AddLine('*)',Lines);
+end;
+
+procedure TFPDDPopulateCodeGenerator.CreateCode(Lines: TStrings);
+
+Var
+  I : Integer;
+  T : TDDTableDef;
+  F : TDDFieldDef;
+
+begin
+  FCurrentIndent:=0;
+  CheckDataDict;
+  FProcedures:=TStringList.Create;
+  try
+    CreateHeader(Lines);
+    Try
+    For I:=0 to FDD.Tables.Count-1 do
+      begin
+      T:=FDD.Tables[i];
+      If DoTable(T) then
+        CreateTableCode(T,Lines);
+      end;
+    Finally
+      CreateFooter(Lines);
+    end;
+    If (dcoClassDecl in Options) and (FClassName<>'') then
+      CreateClassDecl(Lines);
+  finally
+    FreeAndNil(FProcedures);
+  end;
+end;
+
+end.
+

packages/fcl-db/src/datadict/buildd.lpi

@@ -94,6 +94,9 @@
   </ProjectOptions>
   <CompilerOptions>
     <Version Value="5"/>
+    <SearchPaths>
+      <UnitOutputDirectory Value="../../units/$(TARGETCPU)-$(TARGETOS)"/>
+    </SearchPaths>
     <CodeGeneration>
       <Generate Value="Faster"/>
     </CodeGeneration>

packages/fcl-db/src/datadict/fpdatadict.pp

@@ -28,6 +28,9 @@ Type
                  otConnection,otTableData,otIndexDefs,otIndexDef);
   TDDProgressEvent = Procedure(Sender : TObject; Const Msg : String) of Object;
 
+  TFPDDFieldList = Class;
+  TFPDDIndexList = Class;
+
   { TDDFieldDef }
 
   TDDFieldDef = Class(TIniCollectionItem)
@@ -44,6 +47,7 @@ Type
     FFieldType: TFieldType;
     FHint: String;
     FPrecision: Integer;
+    FProviderFlags: TProviderFlags;
     FReadOnly: Boolean;
     FRequired: Boolean;
     FSize: Integer;
@@ -77,6 +81,7 @@ Type
     Property Size : Integer Read FSize Write FSize Stored IsSizeStored;
     Property Precision : Integer Read FPrecision Write FPrecision Stored IsPrecisionStored;
     Property Hint : String Read FHint Write FHint;
+    Property ProviderFlags : TProviderFlags Read FProviderFlags Write FProviderFlags;
   end;
   
   { TDDFieldDefs }
@@ -93,6 +98,7 @@ Type
     Function IndexOfField(AFieldName : String) : Integer;
     Function FindField(AFieldName : String) : TDDFieldDef;
     Function FieldByName(AFieldName : String) : TDDFieldDef;
+    Procedure FillFieldList(Const AFieldNames: String; List : TFPDDFieldList);
     Property Fields[Index : Integer] : TDDFieldDef Read GetField Write SetField; default;
     Property TableName : String Read FTableName Write SetTableName;
   end;
@@ -111,6 +117,9 @@ Type
     function GetSectionName: String; override;
     procedure SetSectionName(const Value: String); override;
     procedure Assign(ASource : TPersistent); override;
+  Public
+    Procedure SaveToIni(Ini: TCustomInifile; ASection : String); override;
+    Procedure LoadFromIni(Ini: TCustomInifile; ASection : String); override;
   Published
     Property IndexName : String Read FIndexName Write FIndexName;
     property Expression: string read FExpression write FExpression;
@@ -232,6 +241,17 @@ Type
     Property FieldDefs[Index : Integer] : TDDFieldDef Read GetFieldDef Write SetFieldDef; default;
   end;
   
+  { TFPDDIndexList }
+
+  TFPDDIndexList = Class(TObjectList)
+  private
+    function GetIndexDef(AIndex : Integer): TDDIndexDef;
+    procedure SetIndexDef(AIndex : Integer; const AValue: TDDIndexDef);
+  Public
+    Constructor CreateFromIndexDefs(FD : TDDIndexDefs);
+    Property IndexDefs[AIndex : Integer] : TDDIndexDef Read GetIndexDef Write SetIndexDef; default;
+  end;
+
   
 
   
@@ -249,6 +269,7 @@ Type
     FOptions: TSQLEngineOptions;
     FTableDef: TDDTableDef;
     FNoIndent : Boolean;
+    FTerminator: String;
     FTerminatorChar : Char;
   Protected
     procedure CheckTableDef;
@@ -279,12 +300,18 @@ Type
     Procedure CreateDeleteSQLStrings(KeyFields : TFPDDFieldList; SQL : TStrings);
     Procedure CreateCreateSQLStrings(Fields,KeyFields : TFPDDFieldList; SQL : TStrings);
     Procedure CreateCreateSQLStrings(KeyFields : TFPDDFieldList; SQL : TStrings);
+    Procedure CreateIndexesSQLStrings(Indexes : TFPDDIndexList; SQL : TStrings);
     Function  CreateSelectSQL(FieldList,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateInsertSQL(FieldList : TFPDDFieldList) : String; virtual;
     Function  CreateUpdateSQL(FieldList,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateDeleteSQL(KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateCreateSQL(Fields,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateCreateSQL(KeyFields : TFPDDFieldList) : String; virtual;
+    Function  CreateIndexSQL(Index : TDDIndexDef) : String; virtual;
+    Function  CreateIndexesSQL(Indexes : TFPDDIndexList) : String;
+    Function  CreateIndexesSQL(Indexes : TDDIndexDefs) : String;
+    Function  CreateTableSQL : String;
+    Procedure CreateTableSQLStrings(SQL : TStrings);
     Property TableDef : TDDTableDef Read FTableDef Write FTableDef;
   Published
     Property MaxLineLength : Integer Read FMaxLineLength Write FMaxLineLength default 72;
@@ -404,8 +431,18 @@ Const
   KeyRequired               = 'Required';
   KeyVisible                = 'Visible';
   KeySize                   = 'Size';
+  KeyPrecision              = 'Precision';
   KeyFieldType              = 'FieldType';
   KeyHint                   = 'Hint';
+  KeyProviderFlags          = 'Providerflags';
+  
+  // Index saving
+  KeyExpression             = 'Expression';
+  KeyFields                 = 'Fields';
+  KeyCaseInsFields          = 'CaseInsFields';
+  KeyDescFields             = 'DescFields';
+  KeySource                 = 'Source';
+  KeyOptions                = 'Options';
 
   // SQL Keywords
   SSelect      = 'SELECT';
@@ -430,7 +467,7 @@ Const
     'BOOL', 'FLOAT', 'DECIMAL','DECIMAL','DATE', 'TIME', 'TIMESTAMP',
     '', '', 'INT', 'BLOB', 'BLOB', 'BLOB', 'BLOB',
     '', '', '', '', 'CHAR',
-    'CHAR', 'DOUBLE PRECISION', '', '', '',
+    'CHAR', 'BIGINT', '', '', '',
     '', '', '', '', '',
     '', '', 'TIMESTAMP', 'DECIMAL','CHAR','BLOB');
     
@@ -729,6 +766,7 @@ begin
     ReadOnly:=F.ReadOnly;
     Required:=F.Required;
     Visible:=F.Visible;
+    ProviderFlags:=F.ProviderFlags;
   end;
 end;
 
@@ -749,7 +787,7 @@ begin
   F.ReadOnly               := ReadOnly;
   F.Required               := Required;
   F.Visible                := Visible;
-
+  F.ProviderFlags          := ProviderFlags;
 end;
 
 procedure TDDFieldDef.Assign(Source: TPersistent);
@@ -779,18 +817,26 @@ begin
     ReadOnly:=DF.ReadOnly;
     Required:=DF.Required;
     Visible:=DF.Visible;
+    ProviderFlags:=DF.ProviderFlags;
     end
   else
     Inherited;
 end;
 
 procedure TDDFieldDef.SaveToIni(Ini: TCustomInifile; ASection: String);
+
+Var
+  T : PTypeInfo;
+  O : Integer;
+
 begin
   With Ini do
     begin
     WriteInteger(ASection,KeyFieldType,Ord(Fieldtype));
     If IsSizeStored then
-      WriteInteger(ASection,KeySize,Ord(Size));
+      WriteInteger(ASection,KeySize,Size);
+    If IsPrecisionStored then
+      WriteInteger(ASection,KeyPrecision,Precision);
     WriteInteger(ASection,KeyAlignMent,Ord(AlignMent));
     WriteInteger(ASection,KeyDisplayWidth,DisplayWidth);
     WriteString(ASection,KeyCustomConstraint,CustomConstraint);
@@ -801,6 +847,9 @@ begin
     WriteString(ASection,KeyFieldName,FieldName);
     WriteString(ASection,KeyConstraint,Constraint);
     WriteString(ASection,KeyHint,Hint);
+    O:=Integer(ProviderFlags);
+    T:=TypeInfo(TProviderFlags);
+    WriteString(ASection,KeyProviderFlags,SetToString(T,O,False));
     WriteBool(ASection,KeyReadOnly,ReadOnly);
     WriteBool(ASection,KeyRequired,Required);
     WriteBool(ASection,KeyVisible,Visible);
@@ -809,12 +858,20 @@ end;
 
 procedure TDDFieldDef.LoadFromIni(Ini: TCustomInifile; ASection: String);
 
+Var
+  T : PTypeInfo;
+  O : Integer;
+  PF : TProviderFlags;
+  S : String;
+
 begin
   With Ini do
     begin
     FieldType:=TFieldType(ReadInteger(ASection,KeyFieldType,Ord(Fieldtype)));
     If IsSizeStored then
       Size:=ReadInteger(ASection,KeySize,0);
+    If IsPrecisionStored then
+      Precision:=ReadInteger(ASection,KeyPrecision,0);
     Alignment:=TAlignment(ReadInteger(ASection,KeyAlignMent,Ord(AlignMent)));
     DisplayWidth:=ReadInteger(ASection,KeyDisplayWidth,DisplayWidth);
     CustomConstraint:=ReadString(ASection,KeyCustomConstraint,CustomConstraint);
@@ -825,6 +882,11 @@ begin
     FieldName:=ReadString(ASection,KeyFieldName,FieldName);
     Constraint:=ReadString(ASection,KeyConstraint,Constraint);
     Hint:=ReadString(ASection,KeyHint,Hint);
+    S:=ReadString(ASection,KeyProviderFlags,'');
+    T:=TypeInfo(TProviderFlags);
+    O:=StringToSet(T,S);
+    Integer(PF):=O;
+    ProviderFlags:=PF;
     ReadOnly:=ReadBool(ASection,KeyReadOnly,ReadOnly);
     Required:=ReadBool(ASection,KeyRequired,Required);
     Visible:=ReadBool(ASection,KeyVisible,Visible);
@@ -906,6 +968,26 @@ begin
     Raise EDatadict.CreateFmt(SErrFieldNotFound,[TableName,AFieldName]);
 end;
 
+procedure TDDFieldDefs.FillFieldList(const AFieldNames: String;
+  List: TFPDDFieldList);
+
+Var
+  I : Integer;
+  S,T : String;
+  F : TDDFieldDef;
+  
+begin
+  T:=Trim(AFieldNames);
+  Repeat
+    I:=Pos(';',T);
+    If I=0 Then
+      I:=Length(T)+1;
+    S:=Trim(Copy(T,1,I-1));
+    System.Delete(T,1,I);
+    List.Add(FieldByName(S));
+  Until (T='');
+end;
+
 { ---------------------------------------------------------------------
   TDDTableDef
   ---------------------------------------------------------------------}
@@ -1572,7 +1654,7 @@ begin
       Result:=Result+Format('(%d)',[FD.Size]);
     ftBCD,
     ftFMTBCD :
-      Result:=Result+Format('(%d,%d)',[FD.Precision,FD.Size]);
+      Result:=Result+Format('(%d,%d)',[FD.Size,FD.Precision]);
   end;
 end;
 
@@ -1776,12 +1858,130 @@ begin
   CheckTableDef;
   FL:=TFPDDfieldList.CreateFromTableDef(TableDef);
   try
+    FL.OwnsObjects:=False;
     Result:=CreateCreateSQL(FL,KeyFields);
   finally
     FL.Free;
   end;
 end;
 
+function TFPDDSQLEngine.CreateIndexSQL(Index: TDDIndexDef): String;
+
+Var
+  L : TFPDDFieldList;
+  I : Integer;
+  
+begin
+  Result:='CREATE ';
+  If ixUnique in Index.Options then
+    Result:=Result+'UNIQUE ';
+  If ixDescending in Index.Options then
+    Result:=Result+'DESCENDING ';
+  Result:=Result+'INDEX '+Index.IndexName;
+  Result:=Result+' ON '+TableDef.TableName+' (';
+  L:=TFPDDFieldList.Create;
+  try
+    L.OwnsObjects:=False;
+    TableDef.Fields.FillFieldList(Index.Fields,L);
+    For I:=0 to L.Count-1 do
+      begin
+      If (I>0) then
+        Result:=Result+',';
+      Result:=Result+L[I].FieldName;
+      end;
+  finally
+    L.Free;
+  end;
+  Result:=Result+')';
+end;
+
+function TFPDDSQLEngine.CreateIndexesSQL(Indexes: TFPDDIndexList): String;
+
+Var
+  SQL : TStringList;
+
+begin
+  SQL:=TStringList.Create;
+  try
+    CreateIndexesSQLStrings(Indexes,SQL);
+    Result:=SQL.Text;
+  finally
+    SQL.free;
+  end;
+end;
+
+function TFPDDSQLEngine.CreateIndexesSQL(Indexes: TDDIndexDefs): String;
+
+Var
+  IL : TFPDDIndexList;
+
+begin
+  IL:=TFPDDIndexList.CreateFromIndexDefs(Indexes);
+  try
+    IL.OwnsObjects:=False;
+    Result:=CreateIndexesSQL(IL);
+  finally
+    IL.Free;
+  end;
+end;
+
+function TFPDDSQLEngine.CreateTableSQL: String;
+
+Var
+  SQL : TStrings;
+
+begin
+  SQL:=TStringList.Create;
+  try
+    CreateTableSQLStrings(SQL);
+    Result:=SQL.Text;
+  finally
+    SQL.Free;
+  end;
+end;
+
+procedure TFPDDSQLEngine.CreateTableSQLStrings(SQL: TStrings);
+
+Var
+  L : TStrings;
+  I : Integer;
+  KF : TFPDDFieldlist;
+  ID : TDDIndexDef;
+  FD : TDDFieldDef;
+  
+begin
+  CheckTableDef;
+  L:=TStringList.Create;
+  try
+    KF:=TFPDDFieldlist.Create(False);
+    try
+      KF.OwnsObjects:=False;
+      I:=0;
+      While (I<TableDef.Indexes.Count) and (KF.Count=0) do
+        begin
+        ID:=TableDef.Indexes[i];
+        If (ixPrimary in ID.Options) then
+          TableDef.Fields.FillFieldList(ID.Fields,KF);
+        Inc(I);
+        end;
+      If (KF.Count=0) then
+        For I:=0 to TableDef.Fields.Count-1 do
+          begin
+          FD:=TableDef.Fields[I];
+          If pfInKey in FD.ProviderFlags then
+            KF.Add(FD);
+          end;
+      CreateCreateSQLStrings(KF,SQL);
+      L.Text:=CreateIndexesSQL(TableDef.Indexes);
+      SQL.AddStrings(L);
+    finally
+      KF.Free;
+    end;
+  finally
+    L.Free;
+  end;
+end;
+
 { TStrings versions of SQL creation statements. }
 
 procedure TFPDDSQLEngine.CreateSelectSQLStrings(FieldList,KeyFields: TFPDDFieldList; SQL: TStrings);
@@ -1819,6 +2019,16 @@ begin
   SQL.Text:=CreateCreateSQL(KeyFields);
 end;
 
+procedure TFPDDSQLEngine.CreateIndexesSQLStrings(Indexes: TFPDDIndexList; SQL: TStrings);
+
+Var
+  I : integer;
+
+begin
+  For I:=0 to Indexes.Count-1 do
+    SQL.Add(CreateIndexSQL(Indexes[i])+TerminatorChar);
+end;
+
 { ---------------------------------------------------------------------
   TDDFieldList
   ---------------------------------------------------------------------}
@@ -1851,6 +2061,28 @@ begin
     Add(FD[i]);
 end;
 
+function TFPDDIndexList.GetIndexDef(AIndex: Integer): TDDIndexDef;
+begin
+  Result:=TDDIndexDef(Items[AIndex]);
+end;
+
+procedure TFPDDIndexList.SetIndexDef(AIndex: Integer; const AValue: TDDIndexDef
+  );
+begin
+  Items[AIndex]:=AValue
+end;
+
+constructor TFPDDIndexList.CreateFromIndexDefs(FD: TDDIndexDefs);
+
+var
+  I : Integer;
+
+begin
+  Inherited Create;
+  For I:=0 to FD.Count-1 do
+    Add(FD[I]);
+end;
+
 { TDDIndexDef }
 
 function TDDIndexDef.GetSectionName: String;
@@ -1896,6 +2128,50 @@ begin
     inherited Assign(ASource);
 end;
 
+procedure TDDIndexDef.SaveToIni(Ini: TCustomInifile; ASection: String);
+
+Var
+  O : Integer;
+  T : PTypeInfo;
+  
+begin
+  With Ini do
+    begin
+    WriteString(ASection,KeyExpression,Expression);
+    WriteString(ASection,KeyFields,Fields);
+    WriteString(ASection,KeyCaseInsFields,CaseInsFields);
+    WriteString(ASection,KeyDescFields,DescFields);
+    WriteString(ASection,KeySource,Source);
+    O:=Integer(Options);
+    T:=TypeInfo(TIndexOptions);
+    WriteString(ASection,KeyOptions,SetToString(T,O,False));
+    end;
+end;
+
+procedure TDDIndexDef.LoadFromIni(Ini: TCustomInifile; ASection: String);
+
+Var
+  O : Integer;
+  OP : TIndexOptions;
+  T : PTypeInfo;
+  S : String;
+
+begin
+  With Ini do
+    begin
+    Expression:=ReadString(ASection,KeyExpression,'');
+    Fields:=ReadString(ASection,KeyFields,'');
+    CaseInsFields:=ReadString(ASection,KeyCaseInsFields,'');
+    DescFields:=ReadString(ASection,KeyDescFields,'');
+    Source:=ReadString(ASection,KeySource,'');
+    S:=ReadString(ASection,KeyOptions,'');
+    T:=TypeInfo(TIndexOptions);
+    O:=StringToSet(T,S);
+    OP:=TIndexOptions(O);
+    Options:=OP;
+    end;
+end;
+
 { TDDIndexDefs }
 
 function TDDIndexDefs.GetIndex(Index : Integer): TDDIndexDef;

packages/fcl-db/src/sqldb/sqldb.pp

@@ -20,7 +20,7 @@ unit sqldb;
 
 interface
 
-uses SysUtils, Classes, DB, bufdataset;
+uses SysUtils, Classes, DB, bufdataset, sqlscript;
 
 type TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages);
      TConnOption = (sqSupportParams,sqEscapeSlash,sqEscapeRepeat,sqQuoteFieldnames);
@@ -359,24 +359,37 @@ type
 
 { TSQLScript }
 
-  TSQLScript = class (Tcomponent)
+  TSQLScript = class (TCustomSQLscript)
   private
-    FScript  : TStrings;
+    FOnDirective: TSQLScriptDirectiveEvent;
     FQuery   : TCustomSQLQuery;
     FDatabase : TDatabase;
     FTransaction : TDBTransaction;
   protected
-    procedure SetScript(const AValue: TStrings);
+    procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
+    procedure ExecuteCommit; override;
     Procedure SetDatabase (Value : TDatabase); virtual;
     Procedure SetTransaction(Value : TDBTransaction); virtual;
     Procedure CheckDatabase;
   public
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
+    procedure Execute; override;
     procedure ExecuteScript;
-    Property Script : TStrings Read FScript Write SetScript;
+  published
     Property DataBase : TDatabase Read FDatabase Write SetDatabase;
     Property Transaction : TDBTransaction Read FTransaction Write SetTransaction;
+    property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
+    property Directives;
+    property Defines;
+    property Script;
+    property Terminator;
+    property CommentsinSQL;
+    property UseSetTerm;
+    property UseCommit;
+    property UseDefines;
+    property OnException;
   end;
 
   { TSQLConnector }
@@ -1521,7 +1534,8 @@ begin
     If Assigned(AValue) then
       begin
       AValue.FreeNotification(Self);  
-      FMasterLink:=TMasterParamsDataLink.Create(Self);
+      If (FMasterLink=Nil) then
+        FMasterLink:=TMasterParamsDataLink.Create(Self);
       FMasterLink.Datasource:=AValue;
       end
     else
@@ -1548,9 +1562,29 @@ end;
 
 { TSQLScript }
 
-procedure TSQLScript.SetScript(const AValue: TStrings);
+procedure TSQLScript.ExecuteStatement(SQLStatement: TStrings;
+  var StopExecution: Boolean);
+begin
+  fquery.SQL.assign(SQLStatement);
+  fquery.ExecSQL;
+end;
+
+procedure TSQLScript.ExecuteDirective(Directive, Argument: String;
+  var StopExecution: Boolean);
 begin
-  FScript.assign(AValue);
+  if assigned (FOnDirective) then
+    FOnDirective (Self, Directive, Argument, StopExecution);
+end;
+
+procedure TSQLScript.ExecuteCommit;
+begin
+  if FTransaction is TSQLTransaction then
+    TSQLTransaction(FTransaction).CommitRetaining
+  else
+    begin
+    FTransaction.Active := false;
+    FTransaction.Active := true;
+    end;
 end;
 
 procedure TSQLScript.SetDatabase(Value: TDatabase);
@@ -1572,49 +1606,28 @@ end;
 constructor TSQLScript.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
-  FScript := TStringList.Create;
-  FQuery := TCustomSQLQuery.Create(nil);
+  FQuery := TCustomSQLQuery.Create(nil); 
 end;
 
 destructor TSQLScript.Destroy;
 begin
-  FScript.Free;
   FQuery.Free;
   inherited Destroy;
 end;
 
-procedure TSQLScript.ExecuteScript;
-
-var BufStr         : String;
-    pBufStatStart,
-    pBufPos        : PChar;
-    Statement      : String;
-
+procedure TSQLScript.Execute;
 begin
   FQuery.DataBase := FDatabase;
   FQuery.Transaction := FTransaction;
+  inherited Execute;
+end;
 
-  BufStr := FScript.Text;
-  pBufPos := @BufStr[1];
-
-  repeat
-
-  pBufStatStart := pBufPos;
-  repeat
-  inc(pBufPos);
-  until (pBufPos^ = ';') or (pBufPos^ = #0);
-  SetLength(statement,pbufpos-pBufStatStart);
-  move(pBufStatStart^,Statement[1],pbufpos-pBufStatStart);
-  if trim(statement) <> '' then
-    begin
-    fquery.SQL.Text := Statement;
-    fquery.ExecSQL;
-    inc(pBufPos);
-    end;
-
-  until pBufPos^ = #0;
+procedure TSQLScript.ExecuteScript;
+begin
+  Execute;
 end;
 
+
 { Connection definitions }
 
 Var

packages/fcl-db/tests/testsqlscript.pas

@@ -0,0 +1,808 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2008 by the Free Pascal development team
+
+    FPCUnit SQLScript test.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit testcsqlscript;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, testregistry, sqlscript, fpcunit;
+
+type
+
+  { TMyScript }
+
+  TMyScript = class (TCustomSQLScript)
+  private
+    FExcept: string;
+    FStatements : TStrings;
+    FDirectives : TStrings;
+    FCommits : integer;
+  protected
+    procedure ExecuteStatement (SQLStatement: TStrings; var StopExecution: Boolean); override;
+    procedure ExecuteDirective (Directive, Argument: String; var StopExecution: Boolean); override;
+    procedure ExecuteCommit; override;
+    procedure DefaultDirectives; override;
+  public
+    constructor create (AnOwner: TComponent); override;
+    destructor destroy; override;
+    function StatementsExecuted : string;
+    function DirectivesExecuted : string;
+    property DoException : string read FExcept write FExcept;
+    property Aborted;
+    property Line;
+    property Directives;
+    property Defines;
+    property Script;
+    property Terminator;
+    property CommentsinSQL;
+    property UseSetTerm;
+    property UseCommit;
+    property UseDefines;
+    property OnException;
+  end;
+
+  { TTestSQLScript }
+
+  TTestSQLScript = class (TTestCase)
+  private
+    Script : TMyScript;
+    exceptionstatement,
+    exceptionmessage : string;
+    UseContinue : boolean;
+    procedure Add (s :string);
+    procedure AssertStatDir (Statements, Directives : string);
+    procedure DoExecution;
+    procedure ExceptionHandler(Sender: TObject; Statement: TStrings; TheException: Exception; var Continue: boolean);
+    procedure TestDirectiveOnException3;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure TestCreateDefaults;
+    procedure TestTerminator;
+    procedure TestSetTerm;
+    procedure TestUseSetTerm;
+    procedure TestComments;
+    procedure TestUseComments;
+    procedure TestCommit;
+    procedure TestUseCommit;
+    procedure TestDefine;
+    procedure TestUndefine;
+    procedure TestUndef;
+    procedure TestIfdef1;
+    procedure TestIfdef2;
+    procedure TestIfndef1;
+    procedure TestIfndef2;
+    procedure TestElse1;
+    procedure TestElse2;
+    procedure TestEndif1;
+    procedure TestEndif2;
+    procedure TestUseDefines;
+    procedure TestTermInComment;
+    procedure TestTermInQuotes1;
+    procedure TestTermInQuotes2;
+    procedure TestCommentInComment;
+    procedure TestCommentInQuotes1;
+    procedure TestCommentInQuotes2;
+    procedure TestQuote1InComment;
+    procedure TestQuote2InComment;
+    procedure TestQuoteInQuotes1;
+    procedure TestQuoteInQuotes2;
+    procedure TestStatementStop;
+    procedure TestDirectiveStop;
+    procedure TestStatementExeception;
+    procedure TestDirectiveException;
+    procedure TestCommitException;
+    procedure TestStatementOnExeception1;
+    procedure TestStatementOnExeception2;
+    procedure TestDirectiveOnException1;
+    procedure TestDirectiveOnException2;
+    procedure TestCommitOnException1;
+    procedure TestCommitOnException2;
+  end;
+
+  { TTestEventSQLScript }
+
+  TTestEventSQLScript = class (TTestCase)
+  private
+    Script : TEventSQLScript;
+    StopToSend : boolean;
+    Received : string;
+    notifycount : integer;
+    LastSender : TObject;
+    procedure Notify (Sender : TObject);
+    procedure NotifyStatement (Sender: TObject; SQL_Statement: TStrings; var StopExecution: Boolean);
+    procedure NotifyDirective (Sender: TObject; Directive, Argument: AnsiString; var StopExecution: Boolean);
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure TestStatement;
+    procedure TestStatementStop;
+    procedure TestDirective;
+    procedure TestDirectiveStop;
+    procedure TestCommit;
+    procedure TestBeforeExec;
+    procedure TestAfterExec;
+  end;
+
+implementation
+
+{ TMyScript }
+
+procedure TMyScript.ExecuteStatement(SQLStatement: TStrings; var StopExecution: Boolean);
+var s : string;
+    r : integer;
+begin
+  if (SQLStatement.count = 1) and (compareText(SQLStatement[0],'END')=0) then
+    StopExecution := true;
+  s := '';
+  for r := 0 to SQLstatement.count-1 do
+    begin
+    if s <> '' then
+      s := s + ' ';
+    s := s + SQLStatement[r];
+    end;
+  FStatements.Add (s);
+  if DoException <> '' then
+    raise exception.create(DoException);
+end;
+
+procedure TMyScript.ExecuteDirective(Directive, Argument: String; var StopExecution: Boolean);
+begin
+  if Directive = 'STOP' then
+    StopExecution := true;
+  if Argument = '' then
+    FDirectives.Add (Directive)
+  else
+    FDirectives.Add (format('%s(%s)', [Directive, Argument]));
+  if DoException <> '' then
+    raise exception.create(DoException);
+end;
+
+procedure TMyScript.ExecuteCommit;
+begin
+  inc (FCommits);
+  if DoException <> '' then
+    raise exception.create(DoException);
+end;
+
+procedure TMyScript.DefaultDirectives;
+begin
+  inherited DefaultDirectives;
+  directives.add ('STOP');
+end;
+
+constructor TMyScript.create (AnOwner: TComponent);
+begin
+  inherited create (AnOwner);
+  FStatements := TStringlist.Create;
+  FDirectives := TStringlist.Create;
+  FCommits := 0;
+  DoException := '';
+end;
+
+destructor TMyScript.destroy;
+begin
+  FStatements.Free;
+  FDirectives.Free;
+  inherited destroy;
+end;
+
+function TMyScript.StatementsExecuted: string;
+begin
+  result := FStatements.Commatext;
+end;
+
+function TMyScript.DirectivesExecuted: string;
+begin
+  result := FDirectives.Commatext;
+end;
+
+
+{ TTestSQLScript }
+
+procedure TTestSQLScript.Add(s: string);
+begin
+  Script.Script.Add (s);
+end;
+
+procedure TTestSQLScript.AssertStatDir(Statements, Directives: string);
+begin
+  AssertEquals ('Executed Statements', Statements, script.StatementsExecuted);
+  AssertEquals ('Executed Directives', Directives, script.DirectivesExecuted);
+end;
+
+procedure TTestSQLScript.DoExecution;
+begin
+  script.execute;
+end;
+
+procedure TTestSQLScript.ExceptionHandler(Sender: TObject; Statement: TStrings;
+  TheException: Exception; var Continue: boolean);
+var r : integer;
+    s : string;
+begin
+  Continue := UseContinue;
+  if Statement.count > 0 then
+    s := Statement[0];
+  for r := 1 to Statement.count-1 do
+    s := s + ',' + Statement[r];
+  exceptionstatement := s;
+  exceptionmessage := TheException.message;
+end;
+
+procedure TTestSQLScript.SetUp;
+begin
+  inherited SetUp;
+  Script := TMyscript.Create (nil);
+end;
+
+procedure TTestSQLScript.TearDown;
+begin
+  Script.Free;
+  inherited TearDown;
+end;
+
+procedure TTestSQLScript.TestCreateDefaults;
+begin
+  with Script do
+    begin
+    AssertEquals ('Terminator', ';', Terminator);
+    AssertTrue ('UseCommit', UseCommit);
+    AssertTrue ('UseSetTerm', UseSetTerm);
+    AssertTrue ('UseDefines', UseDefines);
+    AssertTrue ('CommentsInSQL', CommentsInSQL);
+    AssertFalse ('Aborted', Aborted);
+    AssertEquals ('Line', 0, Line);
+    AssertEquals ('Defines', 0, Defines.count);
+    AssertEquals ('Directives', 10, Directives.count);
+    end;
+end;
+
+procedure TTestSQLScript.TestTerminator;
+begin
+  script.terminator := '!';
+  Add('doe!iets!');
+  Add('anders!');
+  script.execute;
+  AssertStatDir('doe,iets,anders', '');
+end;
+
+procedure TTestSQLScript.TestSetTerm;
+begin
+  script.UseSetTerm:=true;
+  Add('SET TERM !;');
+  script.execute;
+  AssertEquals ('terminator', '!', script.terminator);
+  AssertStatDir('', '');
+end;
+
+procedure TTestSQLScript.TestUseSetTerm;
+begin
+  script.UseSetTerm:=false;
+  Script.Directives.Add ('SET TERM');
+  Add('SET TERM !;');
+  script.execute;
+  AssertEquals ('terminator', ';', script.terminator);
+  AssertStatDir('', '"SET TERM(!)"');
+end;
+
+procedure TTestSQLScript.TestComments;
+begin
+  script.CommentsInSQL := true;
+  Add('/* comment */');
+  Add('statement;');
+  script.execute;
+  AssertStatDir ('"/* comment */ statement"', '');
+end;
+
+procedure TTestSQLScript.TestUseComments;
+begin
+  script.CommentsInSQL := false;
+  Add('/* comment */');
+  Add('statement;');
+  script.execute;
+  AssertStatDir ('statement', '');
+end;
+
+procedure TTestSQLScript.TestCommit;
+begin
+  script.UseCommit := true;
+  Add('commit;');
+  script.execute;
+  AssertEquals ('Commits', 1, script.FCommits);
+  AssertStatDir ('', '');
+end;
+
+procedure TTestSQLScript.TestUseCommit;
+begin
+  script.UseCommit := false;
+  with script.Directives do
+    Delete(IndexOf('COMMIT'));
+  Add('commit;');
+  script.execute;
+  AssertEquals ('Commits', 0, script.FCommits);
+  AssertStatDir ('commit', '');
+end;
+
+procedure TTestSQLScript.TestDefine;
+begin
+  script.UseDefines := true;
+  Add ('#define iets;');
+  script.execute;
+  AssertStatDir ('', '');
+  AssertEquals ('Aantal defines', 1, script.defines.count);
+  AssertEquals ('Juiste define', 'iets', script.Defines[0]);
+end;
+
+procedure TTestSQLScript.TestUndefine;
+begin
+  script.UseDefines := true;
+  script.defines.Add ('iets');
+  Add ('#undefine iets;');
+  script.execute;
+  AssertStatDir ('', '');
+  AssertEquals ('Aantal defines', 0, script.defines.count);
+end;
+
+procedure TTestSQLScript.TestUndef;
+begin
+  script.UseDefines := true;
+  script.defines.Add ('iets');
+  Add ('#Undef iets;');
+  script.execute;
+  AssertStatDir ('', '');
+  AssertEquals ('Aantal defines', 0, script.defines.count);
+end;
+
+procedure TTestSQLScript.TestIfdef1;
+begin
+  script.UseDefines := true;
+  script.defines.add ('iets');
+  Add('#ifdef iets;');
+  Add('doe iets;');
+  script.execute;
+  AssertStatDir('"doe iets"', '');
+end;
+
+procedure TTestSQLScript.TestIfdef2;
+begin
+  script.UseDefines := true;
+  Add('#ifdef iets;');
+  Add('doe iets;');
+  script.execute;
+  AssertStatDir('', '');
+end;
+
+procedure TTestSQLScript.TestIfndef1;
+begin
+  script.UseDefines := true;
+  Add('#ifndef iets;');
+  Add('doe iets;');
+  script.execute;
+  AssertStatDir('"doe iets"', '');
+end;
+
+procedure TTestSQLScript.TestIfndef2;
+begin
+  script.UseDefines := true;
+  script.defines.add ('iets');
+  Add('#ifndef iets;');
+  Add('doe iets;');
+  script.execute;
+  AssertStatDir('', '');
+end;
+
+procedure TTestSQLScript.TestElse1;
+begin
+  script.UseDefines := true;
+  script.defines.add ('iets');
+  Add('#ifdef iets;');
+  Add('doe iets;');
+  add('#else;');
+  add('anders;');
+  script.execute;
+  AssertStatDir('"doe iets"', '');
+end;
+
+procedure TTestSQLScript.TestElse2;
+begin
+  script.UseDefines := true;
+  script.defines.add ('iets');
+  Add('#ifndef iets;');
+  Add('doe iets;');
+  add('#else;');
+  add('anders;');
+  script.execute;
+  AssertStatDir('anders', '');
+end;
+
+procedure TTestSQLScript.TestEndif1;
+begin
+  script.UseDefines := true;
+  Add('#ifdef iets;');
+  Add('doe iets;');
+  add('#endif;');
+  add('anders;');
+  script.execute;
+  AssertStatDir('anders', '');
+end;
+
+procedure TTestSQLScript.TestEndif2;
+begin
+  script.UseDefines := true;
+  Add('#ifndef iets;');
+  Add('doe iets;');
+  add('#endif;');
+  add('anders;');
+  script.execute;
+  AssertStatDir('"doe iets",anders', '');
+end;
+
+procedure TTestSQLScript.TestUseDefines;
+begin
+  script.UseDefines := false;
+  Add('#ifndef iets;');
+  Add('doe iets;');
+  add('#endif;');
+  add('anders;');
+  script.execute;
+  AssertStatDir('"doe iets",anders', '#IFNDEF(iets),#ENDIF');
+end;
+
+procedure TTestSQLScript.TestTermInComment;
+begin
+  script.CommentsInSQL := false;
+  Add('/* terminator ; */iets;');
+  script.execute;
+  AssertStatDir('iets', '');
+end;
+
+procedure TTestSQLScript.TestTermInQuotes1;
+begin
+  script.CommentsInSQL := false;
+  Add('iets '';'';');
+  script.execute;
+  AssertStatDir('"iets '';''"', '');
+end;
+
+procedure TTestSQLScript.TestTermInQuotes2;
+begin
+  script.CommentsInSQL := false;
+  Add('iets ";";');
+  script.execute;
+  AssertStatDir('"iets "";"""', '');
+end;
+
+procedure TTestSQLScript.TestCommentInComment;
+begin
+  script.CommentsInSQL := false;
+  Add('/* meer /* */iets;');
+  script.execute;
+  AssertStatDir('iets', '');
+end;
+
+procedure TTestSQLScript.TestCommentInQuotes1;
+begin
+  script.CommentsInSQL := false;
+  Add('iets ''/* meer */'';');
+  script.execute;
+  AssertStatDir('"iets ''/* meer */''"', '');
+end;
+
+procedure TTestSQLScript.TestCommentInQuotes2;
+begin
+  script.CommentsInSQL := false;
+  Add('iets "/* meer */";');
+  script.execute;
+  AssertStatDir('"iets ""/* meer */"""', '');
+end;
+
+procedure TTestSQLScript.TestQuote1InComment;
+begin
+  script.CommentsInSQL := false;
+  Add('/* s''morgens */iets;');
+  script.execute;
+  AssertStatDir('iets', '');
+end;
+
+procedure TTestSQLScript.TestQuote2InComment;
+begin
+  script.CommentsInSQL := false;
+  Add('/* s"morgens */iets;');
+  script.execute;
+  AssertStatDir('iets', '');
+end;
+
+procedure TTestSQLScript.TestQuoteInQuotes1;
+begin
+  script.CommentsInSQL := false;
+  Add('iets ''s"morgens'';');
+  script.execute;
+  AssertStatDir('"iets ''s""morgens''"', '');
+end;
+
+procedure TTestSQLScript.TestQuoteInQuotes2;
+begin
+  script.CommentsInSQL := false;
+  Add('iets "s''morgens";');
+  script.execute;
+  AssertStatDir('"iets ""s''morgens"""', '');
+end;
+
+procedure TTestSQLScript.TestStatementStop;
+begin
+  Add('END;meer;');
+  script.execute;
+  AssertStatDir('END', '');
+end;
+
+procedure TTestSQLScript.TestDirectiveStop;
+begin
+  Add('Stop;meer;');
+  script.execute;
+  AssertStatDir('', 'STOP');
+end;
+
+procedure TTestSQLScript.TestStatementExeception;
+begin
+  Add('iets;');
+  script.DoException:='FOUT';
+  AssertException (exception, @DoExecution);
+  AssertStatDir('iets', '');
+end;
+
+procedure TTestSQLScript.TestDirectiveException;
+begin
+  Add('iets;');
+  script.Directives.Add('IETS');
+  script.DoException := 'FOUT';
+  AssertException (exception, @DoExecution);
+  AssertStatDir('', 'IETS');
+end;
+
+procedure TTestSQLScript.TestCommitException;
+begin
+  Add ('commit;');
+  script.DoException := 'FOUT';
+  AssertException (exception, @DoExecution);
+  AssertStatDir('', '');
+  AssertEquals ('Commit count', 1, Script.FCommits);
+end;
+
+procedure TTestSQLScript.TestStatementOnExeception1;
+begin
+  UseContinue := true;
+  script.DoException := 'Fout';
+  Add ('foutief;');
+  script.OnException:=@ExceptionHandler;
+  Script.Execute;
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'foutief', exceptionstatement);
+end;
+
+procedure TTestSQLScript.TestStatementOnExeception2;
+begin
+  UseContinue := false;
+  script.DoException := 'Fout';
+  Add ('foutief;');
+  script.OnException:=@ExceptionHandler;
+  AssertException (exception, @DoExecution);
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'foutief', exceptionstatement);
+end;
+
+procedure TTestSQLScript.TestDirectiveOnException1;
+begin
+  UseContinue := true;
+  script.DoException := 'Fout';
+  Add ('foutief;');
+  Script.Directives.Add ('FOUTIEF');
+  script.OnException:=@ExceptionHandler;
+  Script.Execute;
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
+end;
+
+procedure TTestSQLScript.TestDirectiveOnException2;
+begin
+  UseContinue := False;
+  script.DoException := 'Fout';
+  Add ('foutief;');
+  Script.Directives.Add ('FOUTIEF');
+  script.OnException:=@ExceptionHandler;
+  AssertException (exception, @DoExecution);
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'FOUTIEF', exceptionstatement);
+end;
+
+procedure TTestSQLScript.TestDirectiveOnException3;
+begin
+  UseContinue := true;
+  script.DoException := 'Fout';
+  Add ('foutief probleem;');
+  Script.Directives.Add ('FOUTIEF');
+  script.OnException:=@ExceptionHandler;
+  Script.Execute;
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'FOUTIEF,probleem', exceptionstatement);
+end;
+
+procedure TTestSQLScript.TestCommitOnException1;
+begin
+  UseContinue := true;
+  script.DoException := 'Fout';
+  Add ('Commit;');
+  script.OnException:=@ExceptionHandler;
+  Script.Execute;
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
+  AssertEquals ('commit count', 1, Script.FCommits);
+end;
+
+procedure TTestSQLScript.TestCommitOnException2;
+begin
+  UseContinue := false;
+  script.DoException := 'Fout';
+  Add ('Commit;');
+  script.OnException:=@ExceptionHandler;
+  AssertException (exception, @DoExecution);
+  AssertEquals ('exception message', 'Fout', exceptionmessage);
+  AssertEquals ('exception statement', 'COMMIT', exceptionstatement);
+  AssertEquals ('commit count', 1, Script.FCommits);
+end;
+
+{ TTestEventSQLScript }
+
+procedure TTestEventSQLScript.Notify(Sender: TObject);
+begin
+  inc (NotifyCount);
+  LastSender := Sender;
+end;
+
+procedure TTestEventSQLScript.NotifyStatement(Sender: TObject;
+  SQL_Statement: TStrings; var StopExecution: Boolean);
+var r : integer;
+    s : string;
+begin
+  StopExecution := StopToSend;
+  if SQL_Statement.count > 0 then
+    begin
+    s := SQL_Statement[0];
+    for r := 1 to SQL_Statement.count-1 do
+      s := s + ';' + SQL_Statement[r];
+    if SQL_Statement.count > 1 then
+      s := '"' + s + '"';
+    end
+  else
+    s := '';
+  if received <> '' then
+    received := received + ';' + s
+  else
+    received := s;
+  LastSender := Sender;
+end;
+
+procedure TTestEventSQLScript.NotifyDirective(Sender: TObject; Directive,
+  Argument: AnsiString; var StopExecution: Boolean);
+var s : string;
+begin
+  StopExecution := StopToSend;
+  if Argument = '' then
+    s := Directive
+  else
+    s := format ('%s(%s)', [Directive, Argument]);
+  if received <> '' then
+    received := received + ';' + s
+  else
+    received := s;
+  LastSender := Sender;
+end;
+
+procedure TTestEventSQLScript.SetUp;
+begin
+  inherited SetUp;
+  Script := TEventSQLScript.Create (nil);
+  notifycount := 0;
+  Received := '';
+  LastSender := nil;
+end;
+
+procedure TTestEventSQLScript.TearDown;
+begin
+  Script.Free;
+  inherited TearDown;
+end;
+
+procedure TTestEventSQLScript.TestStatement;
+begin
+  StopToSend:=false;
+  Script.OnSQLStatement := @NotifyStatement;
+  Script.Script.Text := 'stat1;stat2;';
+  script.execute;
+  AssertEquals ('Received', 'stat1;stat2', received);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestStatementStop;
+begin
+  StopToSend:=true;
+  Script.OnSQLStatement := @NotifyStatement;
+  Script.Script.Text := 'stat1;stat2;';
+  script.execute;
+  AssertEquals ('Received', 'stat1', received);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestDirective;
+begin
+  StopToSend:=false;
+  Script.OnSQLStatement := @NotifyStatement;
+  Script.OnDirective := @NotifyDirective;
+  script.Directives.Add ('STAT1');
+  Script.Script.Text := 'stat1 ik;stat2;';
+  script.execute;
+  AssertEquals ('Received', 'STAT1(ik);stat2', received);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestDirectiveStop;
+begin
+  StopToSend:=true;
+  Script.OnSQLStatement := @NotifyStatement;
+  Script.OnDirective := @NotifyDirective;
+  script.Directives.Add ('STAT1');
+  Script.Script.Text := 'stat1 ik;stat2;';
+  script.execute;
+  AssertEquals ('Received', 'STAT1(ik)', received);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestCommit;
+begin
+  Script.OnCommit := @Notify;
+  Script.Script.Text := 'iets; commit; anders;';
+  script.execute;
+  AssertEquals ('NotifyCount', 1, NotifyCount);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestBeforeExec;
+begin
+  Script.BeforeExecute := @Notify;
+  Script.Script.Text := 'update iets; anders iets;';
+  script.execute;
+  AssertEquals ('NotifyCount', 1, NotifyCount);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+procedure TTestEventSQLScript.TestAfterExec;
+begin
+  Script.AfterExecute := @Notify;
+  Script.Script.Text := 'update iets; anders iets; en meer;';
+  script.execute;
+  AssertEquals ('NotifyCount', 1, NotifyCount);
+  AssertSame ('Sender', script, LastSender);
+end;
+
+initialization
+
+  RegisterTests ([TTestSQLScript, TTestEventSQLScript]);
+
+end.
+