* Generate parameter map

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

@@ -36,9 +36,10 @@ type
 
   { TFieldMap }
   TTransformMap = class(TObject)
-    function TransFormString(const aString : RawByteString) : RawByteString; virtual;
-    function TransFormString(const aString : UnicodeString) : UnicodeString; virtual;
-    function TransFormString(const aString : WideString) : WideString; virtual;
+  Protected
+    function TransFormString(const aString : RawByteString) : RawByteString; virtual; overload;
+    function TransFormString(const aString : UnicodeString) : UnicodeString; virtual; overload;
+    function TransFormString(const aString : WideString) : WideString; virtual; overload;
   end;
 
   TFieldMap = Class(TTransFormMap)

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

@@ -31,7 +31,7 @@ uses
 Type
 
   { TGenFieldMapOptions }
-  TFieldMapOption = (fmoPublicFields,fmoRequireFields,fmoLoadObject);
+  TFieldMapOption = (fmoPublicFields,fmoRequireFields,fmoLoadObject,fmoCreateParamMap,fmoSaveObject,fmoOverrideTransformString);
   TFieldMapOptions = Set of TFieldMapOption;
 
   TGenFieldMapOptions = Class(TClassCodeGeneratorOptions)
@@ -39,16 +39,24 @@ Type
     FOptions: TFieldMapOptions;
     FMapClassName : String;
     FMapAncestorClassName : String;
+    FParamMapClassName : String;
+    FParamMapAncestorClassName : String;
   Protected
     function GetMapAncestorName: String; virtual;
     function GetMapName: String; virtual;
-    procedure SetMapAncestorName(const AValue: String); virtual;
-    procedure SetMapClassName(const AValue: String); virtual;
+    procedure SetMapAncestorName(const aValue: String); virtual;
+    procedure SetMapClassName(const aValue: String); virtual;
+    function GetParamMapAncestorName: String;virtual;
+    function GetParamMapName: String;virtual;
+    procedure SetParamMapAncestorName(const aValue: String); virtual;
+    procedure SetParamMapClassName(const aValue: String); virtual;
   Public
     Constructor Create; override;
     Procedure Assign(ASource: TPersistent); override;
     Property MapAncestorName : String Read GetMapAncestorName Write SetMapAncestorName;
     Property MapClassName : String Read GetMapName Write SetMapClassName;
+    Property ParamMapAncestorName : String Read GetParamMapAncestorName Write SetParamMapAncestorName;
+    Property ParamMapClassName : String Read GetParamMapName Write SetParamMapClassName;
     Property AncestorClass;
   Published
     Property FieldMapOptions : TFieldMapOptions Read FOptions Write FOptions;
@@ -66,14 +74,21 @@ Type
     Function GetInterfaceUsesClause : string; override;
     Function CreateOptions : TCodeGeneratorOptions; override;
     // New methods
+    procedure AddTransFormOverrideDeclarations(Strings: TStrings); virtual;
+    procedure AddTransFormOverrideImplementations(Strings: TStrings; MapClassName: string); virtual;
     procedure WriteFillMethod(Strings: TStrings; const ObjectClassName, MapClassName: String); virtual;
+    procedure WriteSaveMethod(Strings: TStrings; const ObjectClassName, MapClassName: String); virtual;
     procedure DoCreateFieldMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String); virtual;
+    procedure DoCreateParamMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String); virtual;
     procedure WriteMapInitFields(Strings: TStrings; const ObjectClassName,   MapClassName: String); virtual;
+    procedure WriteParamMapInitParams(Strings: TStrings; const ObjectClassName,   MapClassName: String); virtual;
     procedure CreateFieldMapImplementation(Strings: TStrings; const ObjectClassName, MapClassName: String);
+    procedure CreateParamMapImplementation(Strings: TStrings; const ObjectClassName, MapClassName: String);
     Property FieldMapOpts : TGenFieldMapOptions Read Getopt;
   Public
     Class function NeedsFieldDefs: Boolean; override;
     procedure CreateFieldMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String);
+    procedure CreateParamMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String); virtual;
   end;
 
   { TGenFieldMapCodeGenOptions }
@@ -85,6 +100,8 @@ Type
     Property AncestorClass;
     Property MapClassName;
     Property MapAncestorName;
+    Property ParamMapClassName;
+    Property ParamMapAncestorName;
   end;
 
   TDDDBFieldMapCodeGenerator = Class(TDDBaseFieldMapCodeGenerator)
@@ -131,6 +148,8 @@ begin
   inherited DoGenerateInterface(Strings);
   AddLn(Strings,'Type');
   CreatefieldMapDeclaration(Strings,GetOpt.ObjectClassName,GetOpt.MapClassName,GetOpt.MapAncestorName);
+  if fmoCreateParamMap in GetOpt.FieldMapOptions then
+    CreateParamMapDeclaration(Strings,GetOpt.ObjectClassName,GetOpt.ParamMapClassName,GetOpt.ParamMapAncestorName);
 end;
 
 procedure TDDDBFieldMapCodeGenerator.DoGenerateImplementation(Strings: TStrings
@@ -139,6 +158,8 @@ begin
   inherited DoGenerateImplementation(Strings);
   With FieldMapOpts do
     CreateFieldMapImplementation(Strings,ObjectClassName,MapClassName);
+  if fmoCreateParamMap in GetOpt.FieldMapOptions then
+    CreateParamMapImplementation(Strings,GetOpt.ObjectClassName,GetOpt.ParamMapClassName);
 end;
 
 Function TDDDBFieldMapCodeGenerator.CreateOptions : TCodeGeneratorOptions; 
@@ -153,6 +174,46 @@ begin
   Result:=TGenFieldMapOptions.Create;
 end;
 
+procedure TDDBaseFieldMapCodeGenerator.AddTransFormOverrideDeclarations(Strings : TStrings);
+
+  Procedure Decl(aType : string);
+  begin
+    AddLn(Strings,'function TransFormString(const aString: %s) : %s; override;',[aType,aType]);
+  end;
+
+begin
+  AddLn(Strings,'Protected');
+  IncIndent;
+  Decl('RawByteString');
+  Decl('UnicodeString');
+  Decl('WideString');
+  DecIndent;
+end;
+
+procedure TDDBaseFieldMapCodeGenerator.AddTransFormOverrideImplementations(Strings : TStrings; MapClassName : string);
+
+  Procedure Decl(aType : string);
+
+  var
+    S : String;
+
+  begin
+    S:=Format('function %s.TransFormString(const aString: %s) : %s; ',[MapClassName,aType,atype]);
+    BeginMethod(Strings,S);
+    AddLn(Strings,'begin');
+    IncIndent;
+    AddLn(Strings,'Result:=aString;');
+    DecIndent;
+    EndMethod(Strings,S);
+  end;
+
+begin
+  Decl('RawByteString');
+  Decl('UnicodeString');
+  Decl('WideString');
+end;
+
+
 procedure TDDBaseFieldMapCodeGenerator.DoCreateFieldMapDeclaration(
   Strings: TStrings; const ObjectClassName, MapClassName,
   MapAncestorName: String);
@@ -174,6 +235,8 @@ begin
   Finally
     DecIndent;
   end;
+  if fmoOverrideTransformString in FieldMapOpts.FieldMapOptions then
+    AddTransFormOverrideDeclarations(Strings);
   AddLn(Strings,'Public');
   IncIndent;
   Try
@@ -195,7 +258,70 @@ begin
   end;
 end;
 
+procedure TDDBaseFieldMapCodeGenerator.DoCreateParamMapDeclaration(
+  Strings: TStrings; const ObjectClassName, MapClassName,
+  MapAncestorName: String);
+
+Var
+  I : Integer;
+  F : TFieldPropDef;
+
+begin
+  AddLn(Strings,'Private');
+  IncIndent;
+  Try
+    For I:=0 to Fields.Count-1 do
+      begin
+      F:=Fields[I];
+      If F.Enabled then
+        AddLn(Strings,'F%s : TParam;',[F.PropertyName]);
+      end;
+  Finally
+    DecIndent;
+  end;
+  if fmoOverrideTransformString in FieldMapOpts.FieldMapOptions then
+    AddTransFormOverrideDeclarations(Strings);
+  AddLn(Strings,'Public');
+  IncIndent;
+  Try
+    AddLn(Strings,'Procedure InitParams; Override;');
+    if fmoLoadObject in  FieldMapOpts.FieldMapOptions then
+      begin
+      AddLn(Strings,'Procedure Save(aObject: %s); virtual;',[ObjectClassName]);
+      AddLn(Strings,'Procedure SaveObject(aObject: TObject); override;');
+      end;
+    if fmoPublicFields in  FieldMapOpts.FieldMapOptions then
+      For I:=0 to Fields.Count-1 do
+        begin
+        F:=Fields[I];
+        If F.Enabled then
+          AddLn(Strings,'Property %s : TParam read F%s;',[F.PropertyName,F.FieldName]);
+        end;
+  Finally
+    DecIndent;
+  end;
+end;
+
+
+procedure TDDBaseFieldMapCodeGenerator.CreateParamMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String);
+
+begin
+  Addln(Strings);
+  IncIndent;
+  try
+    Addln(Strings,'{ %s }',[MapClassName]);
+    Addln(Strings);
+    Addln(Strings,'%s = Class(%s)',[MapClassName,MapAncestorName]);
+    DoCreateParamMapDeclaration(Strings,ObjectClassName,MapClassName,MapAncestorName);
+    AddLn(Strings,'end;');
+  Finally
+    DecIndent;
+  end;
+end;
+
+
 procedure TDDBaseFieldMapCodeGenerator.CreateFieldMapDeclaration(Strings: TStrings; const ObjectClassName, MapClassName, MapAncestorName: String);
+
 begin
   Addln(Strings);
   IncIndent;
@@ -210,6 +336,7 @@ begin
   end;
 end;
 
+
 procedure TDDBaseFieldMapCodeGenerator.CreateFieldMapImplementation(
   Strings: TStrings; const ObjectClassName, MapClassName: String);
 
@@ -226,6 +353,8 @@ begin
   Finally
     EndMethod(Strings,S);
   end;
+  if fmoOverrideTransformString in FieldMapOpts.FieldMapOptions then
+    AddTransFormOverrideImplementations(Strings,MapClassName);
   if fmoLoadObject in FieldMapOpts.FieldMapOptions then
     begin
     WriteFillMethod(Strings, ObjectClassName, MapClassName);
@@ -242,6 +371,41 @@ begin
     end;
 end;
 
+procedure TDDBaseFieldMapCodeGenerator.CreateParamMapImplementation(
+  Strings: TStrings; const ObjectClassName, MapClassName: String);
+
+Var
+  S : String;
+
+begin
+  AddLn(Strings,' { %s }',[MapClassName]);
+  AddLn(Strings);
+  S:=Format('Procedure %s.InitParams;',[MapClassName]);
+  BeginMethod(Strings,S);
+  Try
+    WriteParamMapInitParams(Strings,ObjectClassName,MapClassName);
+  Finally
+    EndMethod(Strings,S);
+  end;
+  if fmoOverrideTransformString in FieldMapOpts.FieldMapOptions then
+    AddTransFormOverrideImplementations(Strings,MapClassName);
+  if fmoLoadObject in FieldMapOpts.FieldMapOptions then
+    begin
+    WriteSaveMethod(Strings, ObjectClassName, MapClassName);
+    S:=Format('Procedure %s.SaveObject(aObject: TObject);',[MapClassName]);
+    BeginMethod(Strings,S);
+    Try
+      Addln(Strings,'begin');
+      IncIndent;
+      AddLn(Strings,'Fill(aObject as %s);',[ObjectClassName]);
+      DecIndent;
+    finally
+      EndMethod(Strings,S);
+    end;
+    end;
+end;
+
+
 class function TDDBaseFieldMapCodeGenerator.NeedsFieldDefs: Boolean;
 begin
   Result:=True;
@@ -311,6 +475,71 @@ begin
   end;
 end;
 
+procedure TDDBaseFieldMapCodeGenerator.WriteSaveMethod(Strings: TStrings; const ObjectClassName, MapClassName: String);
+
+Const
+  SAddLoadCode = '// Add code to save property %s (of type %s) to field %s';
+
+  SupportedPropTypes =  [ptBoolean, // Boolean
+                         ptShortString, ptAnsiString, ptUtf8String, // Ansistring
+                         ptWord,ptByte,ptLongint,ptCardinal,ptSmallInt,ptShortInt, // Integer
+                         ptCurrency, // Currency
+                         ptDateTime // DateTime
+                         ];
+
+Var
+  S,Fmt : String;
+  F : TFieldPropDef;
+  I : Integer;
+
+begin
+  S:=Format('Procedure %s.Save(aObject: %s);',[MapClassName,ObjectClassName]);
+  BeginMethod(Strings,S);
+  Try
+    Addln(Strings,'begin');
+    IncIndent;
+    Fmt:='SetParam(Self.F%s,%s);';
+    Addln(Strings,'With aObject do');
+    IncIndent;
+    Addln(Strings,'begin');
+    For I:=0 to Fields.Count-1 Do
+      begin
+      F:=Fields[i];
+      If F.PropertyType in SupportedPropTypes then
+        AddLn(Strings,Fmt,[F.PropertyName,F.PropertyName,F.PropertyName])
+      else if F.PropertyType in [ptWideString, ptUnicodeString] then
+        begin
+        AddLn(Strings,'If Assigned(Self.F%s) then',[F.PropertyName]);
+        incIndent;
+        AddLn(Strings,'%s:=F%s.AsUnicodeString;',[F.PropertyName,F.PropertyName]);
+        DecIndent;
+        end
+      else if F.PropertyType in [ptSingle,ptDouble,ptExtended,ptComp] then
+        begin
+        AddLn(Strings,'If Assigned(Self.F%s) then',[F.PropertyName]);
+        incIndent;
+        AddLn(Strings,'%s:=Self.F%s.AsFloat;',[F.PropertyName,F.PropertyName]);
+        DecIndent;
+        end
+      else if F.PropertyType in [ptInt64,ptQWord] then
+        begin
+        AddLn(Strings,'If Assigned(Self.F%s) then',[F.PropertyName]);
+        incIndent;
+        AddLn(Strings,'%s:=Self.F%s.AsLargeInt;',[F.PropertyName,F.PropertyName]);
+        DecIndent;
+        end
+      else
+        AddLn(Strings,SAddLoadCode,[F.PropertyName,GetEnumName(TypeInfo(TPropType),Ord(F.PropertyType)), F.FieldName]);
+      end;
+    Addln(Strings,'end;');
+    DecIndent;
+  Finally
+    DecIndent;
+    EndMethod(Strings,S);
+  end;
+end;
+
+
 procedure TDDBaseFieldMapCodeGenerator.WriteMapInitFields(Strings: TStrings;
   const ObjectClassName, MapClassName: String);
 
@@ -337,9 +566,60 @@ begin
   end;
 end;
 
+procedure TDDBaseFieldMapCodeGenerator.WriteParamMapInitParams(Strings: TStrings;
+  const ObjectClassName, MapClassName: String);
+
+Const
+  Finders : Array[Boolean] of string = ('FindParam','ParamByName');
+
+Var
+  I: Integer;
+  F : TFieldPropDef;
+  Fmt : String;
+begin
+  AddLn(Strings,'begin');
+  IncIndent;
+  try
+    Fmt:='F%s:='+Finders[fmoRequireFields in FieldMapOpts.FieldMapOptions]+'(%s);';
+    For I:=0 to Fields.Count-1 Do
+      begin
+      F:=Fields[i];
+      If F.Enabled then
+        AddLn(Strings,Fmt,[F.PropertyName,CreateString(F.FieldName)]);
+      end;
+  Finally
+    DecIndent;
+  end;
+end;
+
+
 
 { TGenFieldMapOptions }
 
+function TGenFieldMapOptions.GetParamMapAncestorName: String;
+begin
+  Result:=FParamMapAncestorClassName;
+  if Result='' then
+    Result:='TParamMap';
+end;
+
+function TGenFieldMapOptions.GetParamMapName: String;
+begin
+  Result:=FParamMapClassName;
+  if Result='' then
+    Result:=ObjectClassName+'ParamMap';
+end;
+
+procedure TGenFieldMapOptions.SetParamMapAncestorName(const aValue: String);
+begin
+  FParamMapAncestorClassName:=aValue;
+end;
+
+procedure TGenFieldMapOptions.SetParamMapClassName(const aValue: String);
+begin
+  FParamMapClassName:=aValue;
+end;
+
 function TGenFieldMapOptions.GetMapAncestorName: String;
 begin
   Result:=FMapAncestorClassName;
@@ -354,14 +634,14 @@ begin
     Result:=ObjectClassName+'Map';
 end;
 
-procedure TGenFieldMapOptions.SetMapAncestorName(const AValue: String);
+procedure TGenFieldMapOptions.SetMapAncestorName(const aValue: String);
 begin
-  FMapAncestorClassName:=AValue;
+  FMapAncestorClassName:=aValue;
 end;
 
-procedure TGenFieldMapOptions.SetMapClassName(const AValue: String);
+procedure TGenFieldMapOptions.SetMapClassName(const aValue: String);
 begin
-  FMapClassName:=AValue;
+  FMapClassName:=aValue;
 end;
 
 constructor TGenFieldMapOptions.Create;
@@ -369,11 +649,12 @@ begin
   inherited Create;
   AncestorClass:='TObject';
   ObjectClassName:='TMyObject';
-  MapClassName:='TMyObjectMap';
-  MapAncestorName:='TFieldMap';
+
+  // The rest is auto generated if empty
 end;
 
-procedure TGenFieldMapOptions.Assign(ASource: TPersistent);
+
+procedure TGenFieldMapOptions.Assign(aSource: TPersistent);
 
 Var
   O : TGenFieldMapOptions;
@@ -382,8 +663,10 @@ begin
   if ASource is TGenFieldMapOptions then
     begin
     O:=ASource as TGenFieldMapOptions;
-    MapClassName:=O.MapClassName;
-    MapAncestorName:=O.MapAncestorName;
+    FMapClassName:=O.FMapClassName;
+    FMapAncestorClassName:=O.FMapAncestorClassName;
+    FParamMapClassName:=O.FParamMapClassName;
+    FParamMapAncestorClassName:=O.FParamMapAncestorClassName;
     FieldMapOptions:=O.FieldMapOptions;
     end;
   inherited Assign(ASource);