paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 07:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Initial implementation

Browse Source 
git-svn-id: trunk@9389 -
This commit is contained in:
michael 2007-12-04 15:04:21 +00:00
parent 39e8141f89
commit 4404a27428
8 changed files with 5845 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -4106,6 +4106,13 @@ 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/codegen/Makefile svneol=native#text/plain
packages/fcl-db/src/codegen/Makefile.fpc 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/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

2111
packages/fcl-db/src/codegen/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

24
packages/fcl-db/src/codegen/Makefile.fpc Normal file
View File

@ -0,0 +1,24 @@
#
# Makefile.fpc for SQL FCL db units
#
[package]
main=fcl-db
[require]
packages=fcl-base
[target]
units=fpddcodegen fpcgcreatedbf fpcgdbcoll fpcgsqlconst fpcgtiopf
[compiler]
options=-S2h
[install]
fpcpackage=y
[default]
fpcdir=../../../..
[rules]
.NOTPARALLEL:

258
packages/fcl-db/src/codegen/fpcgcreatedbf.pp Normal file
View File

@ -0,0 +1,258 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Michael Van Canneyt, member of the
Free Pascal development team
Data Dictionary Code Generator Implementation.
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 fpcgcreatedbf;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpddCodeGen;
Type
{ TDDCreateDBFOptions }
TDDCreateDBFOptions = Class(TCodeGeneratorOptions)
private
FIDent: String;
FProcName: String;
FCreateInstance: Boolean;
FTableName: String;
procedure SetIdent(const AValue: String);
procedure SetProcName(const AValue: String);
Public
Constructor Create; override;
Procedure Assign(ASource : TPersistent); override;
Published
Property Identifier : String Read FIDent Write SetIdent;
Property CreateInstance : Boolean Read FCreateInstance Write FCreateInstance default True;
Property ProcedureName : String Read FProcName Write SetProcName;
Property TableName : String Read FTableName Write FTableName;
end;
{ TDDCreateDBFGenerator }
TDDCreateDBFGenerator = Class(TDDCustomCodeGenerator)
Private
FFields: TFieldPropDefs;
Protected
Function ProcedureDecl : String; virtual;
Function CreateOptions : TCodeGeneratorOptions; override;
Procedure DoGenerateImplementation(Strings: TStrings); override;
Procedure DoGenerateInterface(Strings: TStrings); override;
function GetFieldDefs: TFieldPropDefs; override;
procedure SetFieldDefs(const AValue: TFieldPropDefs); override;
Function DBFOptions : TDDCreateDBFOptions;
Function GetImplementationUsesClause : string; override;
Function GetInterfaceUsesClause : string; override;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Class Function NeedsFieldDefs : Boolean; override;
end;
implementation
uses db,typinfo;
{ TDDCreateDBFOptions }
procedure TDDCreateDBFOptions.SetIdent(const AValue: String);
begin
if FIDent=AValue then exit;
If Not IsValidIdent(AValue) then
Raise ECodeGenerator.CreateFmt(SErrInvalidIdentifier,[AValue]);
FIDent:=AValue;
end;
procedure TDDCreateDBFOptions.SetProcName(const AValue: String);
begin
if FProcName=AValue then exit;
If Not IsValidIdent(AValue) then
Raise ECodeGenerator.CreateFmt(SErrInvalidIdentifier,[AValue]);
FProcName:=AValue;
end;
constructor TDDCreateDBFOptions.Create;
begin
inherited Create;
FCreateInstance:=True;
FIdent:='DBF';
FTableName:='MyTable';
FProcName:='CreateDBF';
end;
procedure TDDCreateDBFOptions.Assign(ASource: TPersistent);
Var
DOP : TDDCreateDBFOptions;
begin
if ASource is TDDCreateDBFOptions then
begin
DOP:=ASource as TDDCreateDBFOptions;
FCreateInstance:=DOP.FCreateInstance;
Fident:=DOP.FIdent;
FProcName:=DOP.FProcName;
FTableName:=DOP.FTableName;
end;
inherited Assign(ASource);
end;
{ TDDCreateDBFGenerator }
function TDDCreateDBFGenerator.ProcedureDecl: String;
begin
If not DBFOptions.CreateInstance then
Result:=Format('%s (%s : TDBF)',[DBFoptions.ProcedureName,DBFOptions.Identifier])
else
Result:=DBFoptions.ProcedureName;
Result:=Format('procedure %s;',[Result]);
end;
function TDDCreateDBFGenerator.CreateOptions: TCodeGeneratorOptions;
begin
Result:=TDDCreateDBFOptions.Create;
end;
procedure TDDCreateDBFGenerator.DoGenerateImplementation(Strings: TStrings);
Var
i : integer;
F : TFieldPropDef;
S : String;
N : String;
begin
N:=DBFOptions.Identifier;
If (DBFoptions.ProcedureName<>'') then
begin
BeginMethod(Strings,ProcedureDecl);
If DBFOptions.CreateInstance then
begin
Addln(Strings);
Addln(Strings,'Var');
IncIndent;
Try
Addln(Strings,'%s : TDBF;',[N]);
Finally
DecIndent;
end;
end;
AddLn(Strings,'begin');
IncIndent;
end;
Try
If DBFOptions.CreateInstance then
Addln(Strings,'%s:=TDBF.Create(Nil);',[N]);
Addln(Strings,'With %s do',[N]);
IncIndent;
try
AddLn(Strings,'begin');
If Not DBFOptions.CreateInstance then
AddLn(Strings,'Close;');
AddLn(Strings,'With FieldDefs do');
IncIndent;
try
AddLn(Strings,'begin');
For I:=0 to Fields.Count-1 do
begin
F:=Fields[i];
If F.Enabled then
begin
S:=GetEnumName(TypeInfo(TFieldType),Ord(F.FieldType));
AddLn(Strings,'Add(''%s'',%s,%d);',[F.FieldName,S,F.PropertySize]);
end;
end;
AddLn(Strings,'end;');
Finally
DecIndent;
end;
AddLn(Strings,'TableName:=%s;',[CreateString(DBFOptions.TableName)]);
AddLn(Strings,'CreateTable;');
AddLn(Strings,'Exclusive:=true;');
AddLn(Strings,'Open;');
AddLn(Strings,'end;');
finally
DecIndent;
end;
Finally
If (DBFoptions.ProcedureName<>'') then
begin
DecIndent;
EndMethod(Strings,DBFoptions.ProcedureName);
end;
end;
end;
procedure TDDCreateDBFGenerator.DoGenerateInterface(Strings: TStrings);
begin
If (DBFoptions.ProcedureName<>'') then
BeginMethod(Strings,ProcedureDecl);
end;
function TDDCreateDBFGenerator.GetFieldDefs: TFieldPropDefs;
begin
Result:=FFields;
end;
procedure TDDCreateDBFGenerator.SetFieldDefs(const AValue: TFieldPropDefs);
begin
FFields.Assign(AValue);
end;
function TDDCreateDBFGenerator.DBFOptions: TDDCreateDBFOptions;
begin
Result:=TDDCreateDBFOptions(CodeOptions);
end;
function TDDCreateDBFGenerator.GetImplementationUsesClause: String;
begin
If DBFOptions.CreateInstance then
Result:='db, dbf';
end;
function TDDCreateDBFGenerator.GetInterfaceUsesClause: string;
begin
If Not DBFOptions.CreateInstance then
Result:='db, dbf';
end;
constructor TDDCreateDBFGenerator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFields:=TFieldPropDefs.Create(TFieldPropDef);
end;
destructor TDDCreateDBFGenerator.Destroy;
begin
FreeAndNil(FFields);
inherited Destroy;
end;
class function TDDCreateDBFGenerator.NeedsFieldDefs: Boolean;
begin
Result:=True;
end;
initialization
RegisterCodeGenerator('DBFCreate','Create DBF file for data',TDDCreateDBFGenerator);
Finalization
UnRegisterCodeGenerator(TDDCreateDBFGenerator);
end.

991
packages/fcl-db/src/codegen/fpcgdbcoll.pp Normal file
View File

@ -0,0 +1,991 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Michael Van Canneyt, member of the
Free Pascal development team
Data Dictionary Code Generator Implementation.
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 fpcgdbcoll;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, db, fpddcodegen;
Type
TListMode = (lmNone,lmList,lmObjectList,lmCollection,lmDBCollection);
TClassOption = (coCreateLoader,coUseFieldMap,coCreateArrayProperty,coCreateAssign);
TClassOptions = Set of TClassOption;
{ TDBCollOptions }
TDBCollOptions = Class(TClassCodeGeneratorOptions)
private
FClassOptions: TClassOptions;
FListMode: TListMode;
FListAncestorName: String;
FListClassName: String;
FArrayPropName: String;
FMapAncestorName: String;
FMapClassName: String;
function GetArrayPropName: String;
function GetListClassName: String;
function GetMapName: String;
procedure SetArrayPropName(const AValue: String);
procedure SetListAncestorName(const AValue: String);
procedure SetListClassName(const AValue: String);
procedure SetListMode(const AValue: TListMode);
procedure SetMapAncestorName(const AValue: String);
procedure SetMapClassName(const AValue: String);
Public
Constructor Create; override;
Procedure Assign(ASource : TPersistent); override;
Function CreateLoader : Boolean;
Function UseFieldMap : Boolean;
Function CreateArrayProperty : Boolean;
Function CreateAssign : Boolean;
Published
Property ClassOptions : TClassOptions Read FClassOptions Write FClassOptions;
Property ListMode : TListMode Read FListMode Write SetListMode;
Property ListAncestorName : String Read FListAncestorName Write SetListAncestorName;
Property ListClassName : String Read GetListClassName Write SetListClassName;
Property MapAncestorName : String Read FMapAncestorName Write SetMapAncestorName;
Property MapClassName : String Read GetMapName Write SetMapClassName;
Property ArrayPropName : String Read GetArrayPropName Write SetArrayPropName;
Property AncestorClass;
end;
{ TDDDBCollCodeGenerator }
TDDDBCollCodeGenerator = Class(TDDClassCodeGenerator)
procedure CreateObjectAssign(Strings: TStrings;
const ObjectClassName: String);
private
function GetOpt: TDBColLOptions;
Protected
// Not to be overridden.
procedure CreateFieldMapImplementation(Strings: TStrings; const ObjectClassName, MapClassName: String);
procedure CreateListImplementation(Strings: TStrings; ListMode: TListMode; const ObjectClassName, ListClassName: String);
procedure WriteFieldMapAssign(Strings: TStrings; F: TFieldPropDef);
procedure WriteMapInitFields(Strings: TStrings; const ObjectClassName, MapClassName: String);
procedure WriteListLoad(Strings: TStrings; ListMode: TListMode; const ObjectClassName, ListClassName: String; FromMap: Boolean);
procedure WriteListAddObject(Strings: TStrings; ListMode: TListMode; const InstanceName, ObjectClassName: String);
// Overrides of parent objects
Function GetInterfaceUsesClause : string; override;
Procedure DoGenerateInterface(Strings: TStrings); override;
Procedure DoGenerateImplementation(Strings: TStrings); override;
procedure WriteVisibilityStart(V: TVisibility; Strings: TStrings); override;
procedure CreateImplementation(Strings: TStrings); override;
Class Function NeedsFieldDefs : Boolean; override;
Function CreateOptions : TCodeGeneratorOptions; override;
//
// New methods
//
// Override to add declarations to list declaration
procedure DoCreateListDeclaration(Strings: TStrings; ListMode: TListMode; const ObjectClassName, ListClassName, ListAncestorName: String); virtual;
// Override to add declarations to fieldmap declaration
procedure DoCreateFieldMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName, MapAncestorName: String); virtual;
// Override to add statements to the FieldMap Load implementation
procedure DoWriteMapLoad(Strings: TStrings; const ObjectClassName, MapClassName: String); virtual;
// Override to add statements to the FieldMap LoadObject implementation
procedure DoWriteMapLoadObject(Strings: TStrings; const ObjectClassName, MapClassName: String);virtual;
// Create an object that should be added to the list.
procedure WriteListCreateObject(Strings: TStrings; ListMode: TListMode; const InstanceName, ObjectClassName: String);
// Write LoadFromDataset implementation for List object
procedure WriteListLoadFromDataset(Strings: TStrings; ListMode: TListMode; const ObjectClassName, ListClassName: String);
// Write LoadFromMap implementation for List object
procedure WriteListLoadFromMap(Strings: TStrings; ListMode: TListMode; const ObjectClassName, ListClassName: String);
// Object load from map;
procedure CreateObjectLoadFromMap(Strings: TStrings; const ObjectClassName: String); virtual;
// Create assign statement for a property from a dataset field, in object itself (not in map).
procedure WriteFieldDatasetAssign(Strings: TStrings; F: TFieldPropDef); virtual;
// Copy a property from one instance to another in Assign()
procedure WriteFieldAssign(Strings: TStrings; F: TFieldPropDef); virtual;
// Code to Load object from fataset (should check usefieldmap)
procedure CreateObjectLoadFromDataset(Strings: TStrings; const ObjectClassName: String); virtual;
Public
procedure CreateFieldMapDeclaration(Strings: TStrings; const ObjectClassName,MapClassName,
MapAncestorName: String);
procedure CreateListDeclaration(Strings: TStrings; ListMode: TListMode;
const ObjectClassName, ListClassName, ListAncestorName: String);
Property DBCollOptions : TDBColLOptions Read GetOpt;
end;
implementation
{ TDBCollOptions }
procedure TDBCollOptions.SetListMode(const AValue: TListMode);
begin
if FListMode=AValue then exit;
FListMode:=AValue;
Case ListMode of
lmNone :
begin
Exclude(FClassOptions,coCreateArrayProperty);
end;
lmList :
begin
AncestorClass:='TPersistent';
ListAncestorName:='TList';
end;
lmObjectList :
begin
AncestorClass:='TPersistent';
ListAncestorName:='TObjectList';
end;
lmCollection :
begin
AncestorClass:='TCollectionItem';
ListAncestorName:='TCollection';
end;
lmDBCollection :
begin
AncestorClass:='TDBCollectionItem';
ListAncestorName:='TDBCollection';
Include(FClassoptions,coUseFieldMap);
end;
end;
end;
procedure TDBCollOptions.SetMapAncestorName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FMapAncestorName:=AValue;
end;
procedure TDBCollOptions.SetMapClassName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FMapClassName:=AValue;
end;
function TDBCollOptions.GetListClassName: String;
begin
Result:=FListClassName;
If (Result='') then
Result:=ObjectClassName+'List';
end;
function TDBCollOptions.GetArrayPropName: String;
begin
Result:=FArrayPropName;
If (Result='') then
begin
Result:=ObjectClassName;
If (Result<>'') and (Upcase(Result[1])='T') then
Delete(Result,1,1);
Result:=Result+'s';
end;
end;
function TDBCollOptions.GetMapName: String;
begin
Result:=FMapClassName;
If (Result='') then
Result:=ObjectClassName+'Map';
end;
procedure TDBCollOptions.SetArrayPropName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FArrayPropName:=AValue;
end;
procedure TDBCollOptions.SetListAncestorName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FListAncestorName:=AValue;
end;
procedure TDBCollOptions.SetListClassName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FListClassName:=AValue;
end;
constructor TDBCollOptions.Create;
begin
inherited Create;
FClassOptions:=[coCreateLoader,coUseFieldMap,coCreateAssign];
AncestorClass:='TPersistent';
FListAncestorName:='TList';
ObjectClassName:='TMyObject';
FMapAncestorName:='TFieldMap';
end;
procedure TDBCollOptions.Assign(ASource: TPersistent);
Var
DC : TDBCollOptions;
begin
If ASource is TDBCollOptions then
begin
DC:=ASource as TDBCollOptions;
ListMode:=DC.ListMode;
FClassOptions:=DC.FClassOptions;
FListAncestorName:=DC.FListAncestorName;
FListClassName:=DC.FListClassName;
FMapAncestorName:=DC.FMapAncestorName;
FMapClassName:=DC.FMapClassName;
FArrayPropName:=DC.FArrayPropName;
end;
inherited Assign(ASource);
end;
function TDBCollOptions.CreateLoader: Boolean;
begin
Result:=coCreateLoader in ClassOptions;
end;
function TDBCollOptions.UseFieldMap: Boolean;
begin
Result:=coUseFieldMap in ClassOptions;
end;
function TDBCollOptions.CreateArrayProperty: Boolean;
begin
Result:=coCreateArrayProperty in ClassOptions;
end;
function TDBCollOptions.CreateAssign: Boolean;
begin
Result:=coCreateAssign in ClassOptions;
end;
{ TDDDBCollCodeGenerator }
function TDDDBCollCodeGenerator.GetOpt: TDBColLOptions;
begin
Result:=CodeOptions as TDBColLOptions
end;
procedure TDDDBCollCodeGenerator.DoGenerateInterface(Strings: TStrings);
begin
inherited DoGenerateInterface(Strings);
With DBCollOptions do
begin
If CreateLoader then
begin
if UseFieldMap then
CreateFieldMapDeclaration(Strings,ObjectClassName,MapClassName,MapAncestorName);
end;
if ListMode<>lmNone then
CreateListDeclaration(Strings,ListMode,ObjectClassName,ListClassName,ListAncestorName);
end;
end;
procedure TDDDBCollCodeGenerator.DoGenerateImplementation(Strings: TStrings);
begin
inherited DoGenerateImplementation(Strings);
With DBCollOptions do
begin
If CreateLoader then
If UseFieldMap then
CreateFieldMapImplementation(Strings,ObjectClassName,MapClassName);
if ListMode<>lmNone then
CreateListImplementation(Strings,ListMode,ObjectClassName,ListClassName);
end;
end;
procedure TDDDBCollCodeGenerator.WriteVisibilityStart(V: TVisibility;
Strings: TStrings);
begin
inherited WriteVisibilityStart(V, Strings);
If (V=vPublic) then
With DBCollOptions do
begin
If CreateLoader and (ListMode in [lmList,lmObjectList,lmCollection]) then
begin
If UseFieldMap Then
AddLn(Strings,'Procedure LoadFromMap(Map : TFieldMap);');
AddLn(Strings,'Procedure LoadFromDataset(ADataset : TDataset);');
end;
If CreateAssign then
AddLn(Strings,'Procedure Assign(ASource : TPersistent); override;');
end;
end;
procedure TDDDBCollCodeGenerator.CreateImplementation(Strings: TStrings);
Var
S : String;
begin
inherited CreateImplementation(Strings);
With DBCOlloptions do
begin
If CreateLoader and (ListMode in [lmList,lmObjectList,lmCollection]) then
begin
if UseFieldMap then
begin
S:=Format('Procedure %s.LoadFromMap(Map : TFieldMap);',[ObjectClassName]);
BeginMethod(Strings,S);
CreateObjectLoadFromMap(Strings,ObjectClassName);
EndMethod(Strings,S);
end;
S:=Format('Procedure %s.LoadFromDataset(ADataset : TDataset);',[ObjectClassName]);
BeginMethod(Strings,S);
CreateObjectLoadFromDataset(Strings,ObjectClassName);
EndMethod(Strings,S);
end;
If CreateAssign then
begin
S:=Format('Procedure %s.Assign(ASource : TPersistent);',[ObjectClassName]);
BeginMethod(Strings,S);
CreateObjectAssign(Strings,ObjectClassName);
EndMethod(Strings,S);
end;
end;
end;
procedure TDDDBCollCodeGenerator.CreateObjectAssign(Strings : TStrings; Const ObjectClassName : String);
Var
I : Integer;
F : TFieldPropDef;
begin
AddLn(Strings,'var');
IncIndent;
Try
AddLn(Strings,'O : %s ;',[ObjectClassName]);
Finally
DecIndent;
end;
Addln(Strings,'begin');
IncIndent;
Try
AddLn(Strings,'If (ASource is %s) then',[ObjectClassName]);
IncIndent;
Try
Addln(Strings,'begin');
Addln(Strings,'O:=(ASource as %s);',[ObjectClassName]);
For I:=0 to Fields.Count-1 do
begin
F:=Fields[i];
If F.Enabled Then
WriteFieldAssign(Strings,F);
end;
Addln(Strings,'end');
Finally
DecIndent;
end;
AddLn(Strings,'else');
IncIndent;
Try
AddLn(Strings,'Inherited;');
Finally
DecIndent;
end;
Finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.WriteFieldAssign(Strings : TStrings; F : TFieldPropDef);
Var
S : String;
begin
Case F.PropertyType of
ptStream: S:=Format('%s.CopyFrom(O.%s,0);',[F.ObjPasReadDef,F.ObjPasReadDef]);
ptTStrings: S:=Format('%s.Assign(O.%s,0);',[F.ObjPasReadDef,F.ObjPasReadDef]);
ptCustom: S:=Format('// Custom code to assign %s from O.%s',[F.ObjPasReadDef,F.ObjPasReadDef]);
else
S:=Format('%s:=O.%s;',[F.ObjPasReadDef,F.ObjPasReadDef]);
end;
AddLn(Strings,S);
end;
procedure TDDDBCollCodeGenerator.CreateObjectLoadFromMap(Strings : TStrings; Const ObjectClassName : String);
begin
Addln(Strings,'begin');
IncIndent;
Try
AddLn(Strings,'Map.LoadObject(Self);');
Finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.CreateObjectLoadFromDataset(Strings : TStrings; Const ObjectClassName : String);
Var
I : Integer;
begin
AddLn(Strings,'begin');
Incindent;
try
If DBColloptions.UseFieldMap then
begin
AddLn(Strings,'With %s.Create(ADataset) do',[DBCollOptions.MapClassName]);
IncIndent;
Try
Addln(Strings,'try');
IncIndent;
Try
Addln(Strings,'LoadObject(Self);');
Finally
DecIndent;
end;
Addln(Strings,'Finally');
IncIndent;
Try
Addln(Strings,'Free;');
Finally
DecIndent;
end;
Addln(Strings,'end;');
Finally
Decindent;
end;
end
else
begin
AddLn(Strings,'With ADataset do');
IncIndent;
Try
AddLn(Strings,'begin');
For I:=0 to Fields.Count-1 do
If Fields[i].Enabled then
WriteFieldDatasetAssign(Strings,Fields[i]);
AddLn(Strings,'end;');
Finally
DecIndent;
end;
end;
Finally
Decindent;
end;
end;
procedure TDDDBCollCodeGenerator.WriteFieldDatasetAssign(Strings : TStrings; F : TFieldPropDef);
Var
FN,PN,S,R : String;
begin
PN:=F.PropertyName;
FN:=F.FieldName;
Case F.PropertyType of
ptBoolean :
S:='AsBoolean';
ptShortint, ptByte,
ptSmallInt, ptWord,
ptLongint, ptCardinal :
S:='AsInteger';
ptInt64, ptQWord:
If F.FieldType=ftLargeInt then
R:=Format('%s:=(FieldByName(%s) as TLargeIntField).AsLargeInt;',[PN,CreateString(FN)])
else
S:='AsInteger';
ptShortString, ptAnsiString, ptWideString :
S:='AsString';
ptSingle, ptDouble, ptExtended, ptComp :
S:='AsFloat';
ptCurrency :
S:='AsCurrency';
ptDateTime :
S:='AsDateTime';
ptEnumerated :
R:=Format('Integer(%s):=FieldByName(%s).AsInteger;',[PN,CreateString(FN)]);
ptSet :
S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
ptStream :
R:=Format('FieldByName(%s).SaveToStream(%s);',[CreateString(FN),PN]);
ptTStrings :
R:=Format('%s.Text:=FieldByName(%s).AsString;',[PN,CreateString(FN),PN]);
ptCustom :
R:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
end;
If (S<>'') then
R:=Format('%s:=FieldByName(%s).%s;',[PN,CreateString(FN),s]);
AddLn(Strings,R);
end;
{ FieldMap interface generation routines}
procedure TDDDBCollCodeGenerator.CreateFieldMapDeclaration(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]);
DoCreateFieldMapDeclaration(Strings,ObjectClassName,MapClassName,MapAncestorName);
AddLn(Strings,'end;');
Finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.DoCreateFieldMapDeclaration(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 : TField;',[F.FieldName]);
end;
AddLn(Strings,'Procedure DoLoad(AObject : %s);',[ObjectClassName]);
Finally
DecIndent;
end;
AddLn(Strings,'Public');
IncIndent;
Try
AddLn(Strings,'Procedure InitFields; Override;');
AddLn(Strings,'Procedure LoadObject(AObject : TObject); Override;');
Finally
DecIndent;
end;
end;
{ FieldMap implementation generation routines}
procedure TDDDBCollCodeGenerator.CreateFieldMapImplementation(Strings : TStrings;
Const ObjectClassName,MapClassName : String);
Var
S : String;
begin
AddLn(Strings,' { %s }',[MapClassName]);
AddLn(Strings);
S:=Format('Procedure %s.DoLoad(AObject : %s);',[MapClassName,ObjectClassName]);
BeginMethod(Strings,S);
Try
DoWriteMapLoad(Strings,ObjectClassName,MapClassName);
Finally
EndMethod(Strings,S);
end;
S:=Format('Procedure %s.LoadObject(AObject : TObject);',[MapClassName]);
BeginMethod(Strings,S);
Try
DoWriteMapLoadObject(Strings,ObjectClassName,MapClassName);
Finally
EndMethod(Strings,S);
end;
S:=Format('Procedure %s.InitFields;',[MapClassName]);
BeginMethod(Strings,S);
Try
WriteMapInitFields(Strings,ObjectClassName,MapClassName);
Finally
EndMethod(Strings,S);
end;
end;
procedure TDDDBCollCodeGenerator.DoWriteMapLoad(Strings : TStrings; COnst ObjectClassName,MapClassName : String);
Var
I : Integer;
begin
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'With AObject do');
IncIndent;
try
AddLn(Strings,'begin');
For I:=0 to Fields.Count-1 do
If Fields[i].Enabled then
WriteFieldMapAssign(Strings,Fields[i]);
AddLn(Strings,'end;');
finally
DecIndent;
end;
finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.DoWriteMapLoadObject(Strings : TStrings; Const ObjectClassName,MapClassName : String);
begin
Addln(Strings,'begin');
IncIndent;
try
Addln(Strings,'DoLoad(AObject as %s);',[ObjectClassName]);
finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.WriteFieldMapAssign(Strings : TStrings; F : TFieldPropDef);
Var
FN,PN,S : String;
begin
PN:=F.PropertyName;
FN:='Self.F'+F.FieldName;
Case F.PropertyType of
ptBoolean :
S:=Format('%s:=GetFromField(%s,%s);',[PN,FN,PN]);
ptShortint, ptByte,
ptSmallInt, ptWord,
ptLongint, ptCardinal :
S:=Format('%s:=GetFromField(%s,%s);',[PN,FN,PN]);
ptInt64, ptQWord,
ptShortString, ptAnsiString, ptWideString :
S:=Format('%s:=GetFromField(%s,%s);',[PN,FN,PN]);
ptSingle, ptDouble, ptExtended, ptComp, ptCurrency :
S:=Format('%s:=GetFromField(%s,%s);',[PN,FN,PN]);
ptDateTime :
S:=Format('%s:=GetFromField(%s,%s);',[PN,FN,PN]);
ptEnumerated :
S:=Format('Integer(%s):=GetFromField(%s,Ord(%s));',[PN,FN,PN]);
ptSet :
S:=Format('// Add custom set loading code here for %s from %s',[PN,FN]);
ptStream :
S:=Format('%s.SaveToStream(%s);',[FN,PN]);
ptTStrings :
S:=Format('%s.Text:=GetFromField(%s,%s.Text)',[PN,FN,PN]);
ptCustom :
S:=Format('// Add custom loading code here for %s from %s',[PN,FN]);
end;
AddLn(Strings,S);
end;
procedure TDDDBCollCodeGenerator.WriteMapInitFields(Strings : TStrings; COnst ObjectClassName,MapClassName : String);
Var
I: Integer;
F : TFieldPropDef;
begin
AddLn(Strings,'begin');
IncIndent;
try
For I:=0 to Fields.Count-1 Do
begin
F:=Fields[i];
If F.Enabled then
AddLn(Strings,'F%s:=FindField(%s);',[F.FieldName,CreateString(F.FieldName)]);
end;
Finally
DecIndent;
end;
end;
function TDDDBCollCodeGenerator.GetInterfaceUsesClause: string;
begin
Result:=inherited GetInterfaceUsesClause;
With DBColloptions do
if CreateLoader or (ListMode=lmDBCollection) then
begin
If (Result<>'') then
Result:=Result+', ';
Result:=Result+'db';
If (ListMode=lmObjectList) then
Result:=Result+', contnrs';
If UseFieldMap or (ListMode=lmDBCollection) then
Result:=Result+', dbcoll';
end;
end;
{ List class generation routines }
procedure TDDDBCollCodeGenerator.CreateListDeclaration(Strings : TStrings;
ListMode : TListMode; Const ObjectClassName,ListClassName,ListAncestorName : String);
begin
IncIndent;
try
Addln(Strings);
Addln(Strings,'{ %s }',[ListClassName]);
Addln(Strings);
Addln(Strings,'%s = Class(%s)',[ListClassName,ListAncestorName]);
DoCreateListDeclaration(Strings,ListMode,ObjectClassName,ListClassName,ListAncestorName);
AddLn(Strings,'end;');
Finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.DoCreateListDeclaration(Strings : TStrings;
ListMode : TListMode; Const ObjectClassName,ListClassName,ListAncestorName : String);
Var
S : String;
begin
If DBCollOptions.CreateArrayProperty then
begin
AddLn(Strings,'Private');
IncIndent;
Try
AddLn(Strings,'Function GetObj(Index : Integer) : %s;',[ObjectClassname]);
AddLn(Strings,'Procedure SetObj(Index : Integer; AValue : %s);',[ObjectClassname]);
Finally
DecIndent;
end;
end;
AddLn(Strings,'Public');
IncIndent;
Try
If (ListMode in [lmList,lmObjectList,lmCollection]) and DBCollOptions.CreateLoader then
begin
If DBColloptions.UseFieldMap then
AddLn(Strings,'Procedure LoadFromMap(Map : TFieldMap);');
AddLn(Strings,'Procedure LoadFromDataset(Dataset : TDataset);');
end
Finally
DecIndent;
end;
If DBCollOptions.CreateArrayProperty then
begin
IncIndent;
Try
S:=DBCollOptions.ArrayPropName;
AddLn(Strings,'Property %s[Index : Integer] : %s Read GetObj Write SetObj; Default;',[S,ObjectClassname]);
Finally
DecIndent;
end;
end;
end;
procedure TDDDBCollCodeGenerator.CreateListImplementation(Strings : TStrings;
ListMode : TListMode; Const ObjectClassName,ListClassName : String);
Var
S : String;
begin
If (ListMode in [lmList,lmObjectList,lmCollection]) and DBCollOptions.CreateLoader then
begin
AddLn(Strings,'{ %s }',[ListClassName]);
If DBCollOptions.CreateArrayProperty then
begin
S:=Format('Function %s.GetObj(Index : Integer) : %s;',[ListClassName,ObjectClassname]);
BeginMethod(Strings,S);
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'Result:=%s(Items[Index]);',[ObjectClassname]);
finally
DecIndent;
end;
EndMethod(Strings,S);
S:=Format('Procedure %s.SetObj(Index : Integer; AValue : %s);',[ListClassName,ObjectClassname]);
BeginMethod(Strings,S);
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'Items[Index]:=AValue;');
finally
DecIndent;
end;
EndMethod(Strings,S);
end;
If DBColloptions.UseFieldMap then
begin
AddLn(Strings);
S:=Format('Procedure %s.LoadFromMap(Map : TFieldMap);',[ListClassName]);
BeginMethod(Strings,S);
WriteListLoadFromMap(Strings,Listmode,ObjectClassName,ListClassName);
EndMethod(Strings,S);
end;
AddLn(Strings);
S:=Format('Procedure %s.LoadFromDataset(Dataset : TDataset);',[ListClassName]);
BeginMethod(Strings,S);
WriteListLoadFromDataset(Strings,Listmode,ObjectClassName,ListClassName);
EndMethod(Strings,S);
end;
end;
procedure TDDDBCollCodeGenerator.WriteListLoadFromMap(Strings : TStrings; ListMode : TListMode; Const ObjectClassName,ListClassName : String);
begin
WriteListLoad(Strings,ListMode,ObjectClassName,ListClassName,True);
end;
procedure TDDDBCollCodeGenerator.WriteListLoadFromDataset(Strings : TStrings; ListMode : TListMode; Const ObjectClassName,ListClassName : String);
Var
M : String;
begin
If Not DBCollOptions.UseFieldMap then
WriteListLoad(Strings,ListMode,ObjectClassName,ListClassName,False)
else
begin
M:=DBCollOptions.MapClassName;
AddLn(Strings);
AddLn(Strings,'Var');
IncIndent;
try
AddLn(Strings,'Map : %s;',[M]);
Finally
DecIndent;
end;
AddLn(Strings);
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'Map:=%s.Create(Dataset);',[M]);
AddLn(Strings,'Try');
IncIndent;
try
AddLn(Strings,'LoadFromMap(Map);');
finally
DecIndent;
end;
AddLn(Strings,'Finally');
IncIndent;
try
AddLn(Strings,'FreeAndNil(Map);');
finally
DecIndent;
end;
AddLn(Strings,'end;');
finally
DecIndent;
end;
end;
end;
procedure TDDDBCollCodeGenerator.WriteListLoad(Strings : TStrings; ListMode : TListMode; Const ObjectClassName,ListClassName : String; FromMap : Boolean);
begin
AddLn(Strings);
AddLn(Strings,'Var');
IncIndent;
try
AddLn(Strings,'Obj : %s;',[ObjectClassName]);
Finally
DecIndent;
end;
AddLn(Strings);
AddLn(Strings,'begin');
IncIndent;
try
If FromMap then
begin
AddLn(Strings,'With Map do');
IncIndent;
end;
Try
AddLn(Strings,'While not Dataset.EOF do');
IncIndent;
Try
AddLn(Strings,'begin');
WriteListCreateObject(Strings,ListMode,'Obj',ObjectClassName);
AddLn(Strings,'Try');
IncIndent;
Try
If FromMap then
AddLn(Strings,'LoadObject(Obj);')
else
AddLn(Strings,'Obj.LoadFromDataset(Dataset);');
WriteListAddObject(Strings,ListMode,'Obj',ObjectClassName);
Finally
DecIndent;
end;
AddLn(Strings,'Except');
IncIndent;
Try
AddLn(Strings,'FreeAndNil(Obj);');
AddLn(Strings,'Raise;');
Finally
DecIndent;
end;
AddLn(Strings,'end;');
AddLn(Strings,'Dataset.Next;');
AddLn(Strings,'end;');
Finally
DecIndent;
end;
finally
If FromMap then
DecIndent;
end;
finally
DecIndent;
end;
end;
procedure TDDDBCollCodeGenerator.WriteListCreateObject(Strings : TStrings; ListMode : TListMode; Const InstanceName,ObjectClassName : String);
Var
S : String;
begin
If ListMode in [lmList,lmObjectList] then
S:=Format('%s:=%s.Create;',[InstanceName,ObjectClassName])
else
S:=Format('%s:=Self.Add as %s;',[InstanceName,ObjectClassName]);
AddLn(Strings,S);
end;
procedure TDDDBCollCodeGenerator.WriteListAddObject(Strings : TStrings; ListMode : TListMode; Const InstanceName,ObjectClassName : String);
Var
S : String;
begin
If ListMode in [lmList,lmObjectList] then
begin
S:=Format('Add(%s);',[InstanceName]);
AddLn(Strings,S);
end;
end;
class function TDDDBCollCodeGenerator.NeedsFieldDefs: Boolean;
begin
Result:=True;
end;
function TDDDBCollCodeGenerator.CreateOptions: TCodeGeneratorOptions;
begin
Result:=TDBCollOptions.Create;
end;
Initialization
RegisterCodeGenerator('DBColl','Simple object/collection for the data',TDDDBCollCodeGenerator);
Finalization
UnRegisterCodeGenerator(TDDDBCollCodeGenerator);
end.

208
packages/fcl-db/src/codegen/fpcgsqlconst.pp Normal file
View File

@ -0,0 +1,208 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Michael Van Canneyt, member of the
Free Pascal development team
Data Dictionary Code Generator Implementation.
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 fpcgsqlconst;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpddCodeGen;
Type
{ TDDSQLConstOptions }
TMode = (mConst,mTStrings);
TDDSQLConstOptions = Class(TCodeGeneratorOptions)
private
FIDent: String;
FMode: TMode;
procedure SetIdent(const AValue: String);
Public
Constructor Create; override;
Procedure Assign(ASource : TPersistent); override;
Published
Property Identifier : String Read FIDent Write SetIdent;
Property Mode : TMode Read FMode Write FMode;
end;
{ TDDSQLConstGenerator }
TDDSQLConstGenerator = Class(TDDCustomCodeGenerator)
Private
FSQL : TStrings;
Protected
Function CreateOptions : TCodeGeneratorOptions; override;
Procedure DoGenerateInterface(Strings: TStrings); override;
Procedure DoGenerateImplementation(Strings: TStrings); override;
function GetSQL: TStrings; override;
procedure SetSQL(const AValue: TStrings); override;
Function SQLOptions : TDDSQLConstOptions;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Class Function NeedsSQL : Boolean; override;
Class Function NeedsFieldDefs : Boolean; override;
end;
Const
SSQLConst = 'SQLConst';
Resourcestring
SSQLConstDescr = 'Generate Pascal constant/Stringlist from SQL';
implementation
{ TDDSQLConstOptions }
procedure TDDSQLConstOptions.SetIdent(const AValue: String);
begin
if FIDent=AValue then exit;
If Not IsValidIdent(AValue) then
Raise ECodeGenerator.CreateFmt(SErrInvalidIdentifier,[AValue]);
FIDent:=AValue;
end;
constructor TDDSQLConstOptions.Create;
begin
Inherited;
FIdent:='SQL'; // Do not localize
end;
procedure TDDSQLConstOptions.Assign(ASource: TPersistent);
Var
CO: TDDSQLConstOptions;
begin
If ASource is TDDSQLConstOptions then
begin
CO:=ASource as TDDSQLConstOptions;
FIDent:=CO.FIdent;
FMode:=CO.FMode;
end;
inherited Assign(ASource);
end;
{ TDDSQLConstGenerator }
function TDDSQLConstGenerator.CreateOptions: TCodeGeneratorOptions;
begin
Result:=TDDSQLConstOptions.Create;
end;
procedure TDDSQLConstGenerator.DoGenerateInterface(Strings: TStrings);
Var
S : String;
I,L : Integer;
begin
If (SQLOptions.Mode=mConst) then
begin
Addln(Strings,'Const');
L:=Length(SQLOPtions.Identifier);
IncIndent;
try
For I:=0 to FSQL.Count-1 do
begin
If (I=0) then
S:=SQLOPtions.Identifier+' = '
else
S:=StringOfChar(' ',L)+' +';
S:=S+CreateString(FSQL[i]);
If (I=FSQL.Count-1) then
S:=S+';'
else
S:=S+'+sLineBreak';
Addln(Strings,S);
end;
finally
DecIndent;
end;
end;
end;
procedure TDDSQLConstGenerator.DoGenerateImplementation(Strings: TStrings);
Var
S : String;
I,L : Integer;
begin
If (SQLOptions.Mode=mTStrings) then
begin
Addln(Strings,'With %s do',[SQLOPtions.Identifier]);
IncIndent;
try
Addln(Strings,'begin');
For I:=0 to FSQL.Count-1 do
Addln(Strings,'Add(%s);',[CreateString(FSQL[i])]);
Addln(Strings,'end;');
finally
DecIndent;
end;
end;
end;
function TDDSQLConstGenerator.GetSQL: TStrings;
begin
Result:=FSQL;
end;
procedure TDDSQLConstGenerator.SetSQL(const AValue: TStrings);
begin
FSQL.Assign(AValue);
end;
function TDDSQLConstGenerator.SQLOptions: TDDSQLConstOptions;
begin
Result:=CodeOptions as TDDSQLConstOptions;
end;
constructor TDDSQLConstGenerator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSQL:=TSTringList.Create;
end;
destructor TDDSQLConstGenerator.Destroy;
begin
FreeAndNil(FSQL);
inherited Destroy;
end;
class function TDDSQLConstGenerator.NeedsSQL: Boolean;
begin
Result:=True;
end;
class function TDDSQLConstGenerator.NeedsFieldDefs: Boolean;
begin
Result:=False;
end;
Initialization
RegisterCodeGenerator(SSQLConst, SSQLConstDescr, TDDSQLConstGenerator);
Finalization
UnRegisterCodeGenerator(TDDSQLConstGenerator);
end.

732
packages/fcl-db/src/codegen/fpcgtiopf.pp Normal file
View File

@ -0,0 +1,732 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2007 by Michael Van Canneyt, member of the
Free Pascal development team
Data Dictionary Code Generator Implementation.
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 fpcgtiopf;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, db, fpddcodegen;
TYpe
TClassOption = (caConstructor,caDestructor,caCreateList,caListAddMethod,caListItemsProperty);
TClassOptions = Set of TClassOption;
TVisitorOption = (voRead,voReadList,voCreate,voDelete,voUpdate);
TVisitorOptions = set of TVisitorOption;
{ TTiOPFCodeOptions }
TTiOPFCodeOptions = Class (TClassCodeGeneratorOptions)
Private
FClassOptions: TClassOptions;
FListAncestorName: String;
FListClassName : String;
FVisitorOptions: TVisitorOptions;
function GetListClassName: String;
procedure SetListAncestorName(const AValue: String);
procedure SetListClassName(const AValue: String);
Public
Constructor Create; override;
Procedure Assign(ASource : TPersistent); override;
Published
Property ClassOptions : TClassOptions Read FClassOptions Write FClassOptions;
Property VisitorOptions : TVisitorOptions Read FVisitorOptions Write FVisitorOptions;
Property ListAncestorName : String Read FListAncestorName Write SetListAncestorName;
Property ListClassName : String Read GetListClassName Write SetListClassName;
Property AncestorClass;
end;
{ TTiOPFCodeGenerator }
TTiOPFCodeGenerator = Class(TDDClassCodeGenerator)
procedure CreateListImplementation(Strings: TStrings; const ObjectClassName, ListClassName: String);
function BeginInit(Strings: TStrings; const AClass: String): String;
function BeginAcceptVisitor(Strings: TStrings; const AClass, ObjectClassName: String): String;
function BeginSetupParams(Strings: TStrings; const AClass,ObjectClassName: String; DeclareObject : Boolean): String;
function BeginMapRowToObject(Strings: TStrings; const AClass, ObjectClassName : String): String;
procedure DeclareObjectvariable(Strings: TStrings;
const ObjectClassName: String);
private
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 WriteReadListVisitor(Strings: TStrings; const ObjectClassName: String);
procedure WriteReadVisitor(Strings: TStrings; const ObjectClassName: String );
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);
Protected
// Not to be overridden.
procedure WriteListAddObject(Strings: TStrings; const ListClassName, ObjectClassName: String);
// Overrides of parent objects
Function GetInterfaceUsesClause : string; override;
Procedure DoGenerateInterface(Strings: TStrings); override;
Procedure DoGenerateImplementation(Strings: TStrings); override;
Function NeedsConstructor : Boolean; override;
Function NeedsDestructor : Boolean; override;
Class Function NeedsFieldDefs : Boolean; override;
Function CreateOptions : TCodeGeneratorOptions; override;
//
// New methods
//
// Override to add declarations to list declaration
procedure DoCreateListDeclaration(Strings: TStrings; const ObjectClassName, ListClassName, ListAncestorName: String); virtual;
Public
procedure CreateListDeclaration(Strings: TStrings; const ObjectClassName, ListClassName, ListAncestorName: String);
Property TiOPFOptions : TTiOPFCodeOptions Read GetOpt;
end;
implementation
{ TTiOPFCodeOptions }
function TTiOPFCodeOptions.GetListClassName: String;
begin
Result:=FListClassName;
If (Result='') then
Result:=ObjectClassName+'List';
end;
procedure TTiOPFCodeOptions.SetListAncestorName(const AValue: String);
begin
CheckIdentifier(AValue,False);
FListAncestorName:=AValue;
end;
procedure TTiOPFCodeOptions.SetListClassName(const AValue: String);
begin
CheckIdentifier(AValue,True);
FListClassName:=AValue;
end;
constructor TTiOPFCodeOptions.Create;
begin
inherited Create;
FListAncestorName:='TObjectList';
AncestorClass:='TTiObject';
ObjectClassName:='MyObject';
FVisitorOptions:=[voRead,voCreate,voDelete,voUpdate];
FClassOptions:=[caCreateList,caListAddMethod,caListItemsProperty];
end;
procedure TTiOPFCodeOptions.Assign(ASource: TPersistent);
Var
OC : TTiOPFCodeOptions;
begin
If ASource is TTiOPFCodeOptions then
begin
OC:=ASource as TTiOPFCodeOptions;
FListAncestorName:=OC.FListAncestorName;
AncestorClass:=OC.AncestorClass;
FVisitorOptions:=OC.FVisitorOptions;
FClassOptions:=OC.FClassOptions;
end;
inherited Assign(ASource);
end;
{ TTiOPFCodeGenerator }
{ ---------------------------------------------------------------------
General overrides
---------------------------------------------------------------------}
function TTiOPFCodeGenerator.NeedsConstructor: Boolean;
begin
Result:=inherited NeedsConstructor;
Result:=Result or (caConstructor in TiOPFOptions.ClassOptions);
end;
function TTiOPFCodeGenerator.NeedsDestructor: Boolean;
begin
Result:=inherited NeedsDestructor;
Result:=Result or (caDestructor in TiOPFOptions.ClassOptions);
end;
class function TTiOPFCodeGenerator.NeedsFieldDefs: Boolean;
begin
Result:=True;
end;
function TTiOPFCodeGenerator.CreateOptions: TCodeGeneratorOptions;
begin
Result:=TTiOPFCodeOptions.Create;
end;
function TTiOPFCodeGenerator.GetOpt: TTiOPFCodeOptions;
begin
Result:=CodeOptions as TTiOPFCodeOptions;
end;
function TTiOPFCodeGenerator.GetInterfaceUsesClause: string;
begin
Result:=inherited GetInterfaceUsesClause;
If (Result<>'') then
Result:=Result+',';
Result:=Result+'tiVisitor, tiObject';
end;
procedure TTiOPFCodeGenerator.DoGenerateInterface(Strings: TStrings);
Var
V : TVisitorOption;
begin
inherited DoGenerateInterface(Strings);
With TiOPFOptions do
begin
IncIndent;
try
If caCreateList in ClassOptions then
CreateListDeclaration(Strings,ObjectClassName,ListClassName,ListAncestorName);
For V:=Low(TVisitorOption) to High(TVisitorOption) do
If V in VisitorOptions then
WriteVisitorDeclaration(Strings,V,ObjectClassName);
Finally
DecIndent;
end;
end;
end;
Function StripType(S : String) : string;
begin
Result:=S;
If (Result<>'') and (Result[1]='T') then
Delete(Result,1,1);
end;
procedure TTiOPFCodeGenerator.WriteVisitorDeclaration(Strings : TStrings; V : TVisitorOption; Const ObjectClassName : String);
Var
S,T,A : string;
begin
Case V of
voRead : S:='Read';
voReadList : S:='ReadList';
voCreate : S:='Create';
voDelete : S:='Delete';
voUpdate : S:='Update';
end;
If V in [voCreate,voDelete,voUpdate] then
A:='Update'
else
A:='Select';
S:=Format('T%s%sVisitor',[S,StripType(ObjectClassName)]);
AddLn(Strings,'{ %s }',[S]);
AddlN(Strings,'%s = Class(TtiVisitor%s)',[S,A]);
AddlN(Strings,'Protected');
IncIndent;
Try
AddLn(Strings,'Procedure Init; override;');
AddLn(Strings,'Function AcceptVisitor : Boolean; override;');
AddLn(Strings,'Procedure SetupParams; override;');
If Not (V in [voCreate,voDelete,voUpdate]) then
AddLn(Strings,'Procedure MapRowToObject; override;');
Finally
DecIndent;
end;
AddlN(Strings,'end;');
AddlN(Strings);
end;
procedure TTiOPFCodeGenerator.DoGenerateImplementation(Strings: TStrings);
Var
V : TVisitorOption;
begin
inherited DoGenerateImplementation(Strings);
With TiOPFOptions do
begin
If caCreateList in ClassOptions then
CreateListImplementation(Strings,ObjectClassName,ListClassName);
For V:=Low(TVisitorOption) to High(TVisitorOption) do
If V in VisitorOptions then
WriteVisitorImplementation(Strings,V,ObjectClassName);
end;
end;
{ ---------------------------------------------------------------------
Visitor helper routines
---------------------------------------------------------------------}
procedure TTiOPFCodeGenerator.WriteVisitorImplementation(Strings : TStrings; V : TVisitorOption; Const ObjectClassName : String);
begin
Case V of
voRead : WriteReadVisitor(Strings,ObjectClassName);
voReadList : WriteReadListVisitor(Strings,ObjectClassName);
voCreate : WriteCreateVisitor(Strings,ObjectClassName);
voDelete : WriteDeleteVisitor(Strings,ObjectClassName);
voUpdate : WriteUpdateVisitor(Strings,ObjectClassName);
end;
end;
Function TTiOPFCodeGenerator.BeginInit(Strings : TStrings; const AClass : String) : String;
begin
Result:=Format('Procedure %s.Init;',[AClass]);
BeginMethod(Strings,Result);
AddLn(Strings,'begin');
IncIndent;
end;
Function TTiOPFCodeGenerator.BeginAcceptVisitor(Strings : TStrings; Const AClass, ObjectClassName: String) : String;
begin
Result:=Format('Function %s.AcceptVisitor : Boolean;',[AClass]);
BeginMethod(Strings,Result);
AddLn(Strings,'begin');
IncIndent;
AddLn(Strings,'Result:=Visited is %s;',[ObjectClassName]);
end;
Function TTiOPFCodeGenerator.BeginSetupParams(Strings : TStrings; const AClass,ObjectClassName : String; DeclareObject : Boolean) : String;
begin
Result:=Format('Procedure %s.SetupParams;',[AClass]);
BeginMethod(Strings,Result);
If DeclareObject Then
DeclareObjectVariable(Strings,ObjectClassName);
AddLn(Strings,'begin');
If DeclareObject Then
Addln(Strings,'O:=%s(Visited);',[ObjectClassName]);
IncIndent;
end;
Procedure TTiOPFCodeGenerator.DeclareObjectvariable(Strings : TStrings; Const ObjectClassName : String);
begin
AddLn(Strings,'var');
IncIndent;
try
AddLn(Strings,'O : %s;',[ObjectClassName]);
AddLn(Strings);
finally
DecIndent;
end;
end;
Function TTiOPFCodeGenerator.BeginMapRowToObject(Strings : TStrings; Const AClass,ObjectClassName : String) : String;
begin
Result:=Format('Procedure %s.MapRowToObject;',[AClass]);
BeginMethod(Strings,Result);
DeclareObjectVariable(Strings,ObjectClassName);
AddLn(Strings,'begin');
IncIndent;
end;
{ ---------------------------------------------------------------------
Read Visitor
---------------------------------------------------------------------}
procedure TTiOPFCodeGenerator.WriteReadVisitor(Strings : TStrings; Const ObjectClassName : String);
Var
C,S : String;
I : Integer;
begin
C:=Format('TRead%sVisitor',[StripType(ObjectClassName)]);
Addln(Strings,'{ %s }',[C]);
Addln(Strings);
// Init
S:=BeginInit(Strings,C);
Addln(Strings,'Query.SQL.Text:=SQLReadList;');
DecIndent;
EndMethod(Strings,S);
// AcceptVisitor
S:=BeginAcceptVisitor(Strings,C,ObjectClassName);
DecIndent;
EndMethod(Strings,S);
// AcceptSetupParams
S:=BeginSetupParams(Strings,C,'',False);
AddLn(Strings,'// Set up as needed');
DecIndent;
EndMethod(Strings,S);
// MapRowToObject
S:=BeginMapRowToObject(Strings,C,ObjectClassName);
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;
DecIndent;
EndMethod(Strings,S);
end;
procedure TTiOPFCodeGenerator.WriteFieldAssign(Strings : TStrings; F : TFieldPropDef);
Var
PN,FN,SFN,R,S : String;
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
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);
Var
PN,FN,SFN,R,S : String;
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
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]);
AddLn(Strings,R);
end;
{ ---------------------------------------------------------------------
List Read Visitor
---------------------------------------------------------------------}
procedure TTiOPFCodeGenerator.WriteReadListVisitor(Strings : TStrings; Const ObjectClassName : String);
Var
C,S,LN : String;
I : Integer;
begin
LN:=tiOPFOptions.ListClassName;
C:=Format('TRead%sVisitor',[StripType(LN)]);
Addln(Strings,'{ %s }',[C]);
Addln(Strings);
// Init
S:=BeginInit(Strings,C);
Addln(Strings,'Query.SQL.Text:=SQLReadList;');
DecIndent;
EndMethod(Strings,C);
// AcceptVisitor
S:=BeginAcceptVisitor(Strings,C,LN);
DecIndent;
EndMethod(Strings,S);
// AcceptSetupParams
S:=BeginSetupParams(Strings,C,'',False);
DecIndent;
EndMethod(Strings,S);
// MapRowToObject
S:=BeginMapRowToObject(Strings,S,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,'O.ObjectState:=posClean;');
Addln(Strings,'%s(Visited).Add(O);',[LN]);
DecIndent;
EndMethod(Strings,S);
end;
{ ---------------------------------------------------------------------
Create Visitor
---------------------------------------------------------------------}
procedure TTiOPFCodeGenerator.WriteCreateVisitor(Strings : TStrings; Const ObjectClassName : String);
Var
C,S : String;
I : Integer;
begin
C:=Format('TCreate%sVisitor',[StripType(ObjectClassName)]);
Addln(Strings,'{ %s }',[C]);
Addln(Strings);
// Init
S:=BeginInit(Strings,C);
Addln(Strings,'Query.SQL.Text:=SQLCreateObject;');
DecIndent;
EndMethod(Strings,S);
// AcceptVisitor
S:=BeginAcceptVisitor(Strings,C,ObjectClassName);
AddLn(Strings,'Result:=Result and (Visited.ObjectState=posCreate);');
DecIndent;
EndMethod(Strings,S);
// SetupParams
S:=BeginSetupParams(Strings,C,ObjectClassName,True);
Addln(Strings,'With Query do',[ObjectClassName]);
IncINdent;
try
Addln(Strings,'begin');
For I:=0 to Fields.Count-1 do
If Fields[i].Enabled then
WriteParamAssign(Strings,Fields[i]);
Addln(Strings,'end;');
finally
DecIndent;
end;
DecIndent;
EndMethod(Strings,S);
end;
procedure TTiOPFCodeGenerator.WriteDeleteVisitor(Strings : TStrings; Const ObjectClassName : String);
Var
C,S : String;
begin
C:=Format('TDelete%sVisitor',[StripType(ObjectClassName)]);
Addln(Strings,'{ %s }',[C]);
// Init
S:=BeginInit(Strings,C);
Addln(Strings,'Query.SQL.Text:=SQLDeleteObject;');
DecIndent;
EndMethod(Strings,S);
// AcceptVisitor
S:=BeginAcceptVisitor(Strings,C,ObjectClassName);
AddLn(Strings,'Result:=Result and (Visited.ObjectState=posDelete);');
DecIndent;
EndMethod(Strings,S);
// SetupParams
S:=BeginSetupParams(Strings,C,ObjectClassName,True);
AddLn(Strings,'// Add parameter setup code here ');
DecIndent;
EndMethod(Strings,S);
end;
procedure TTiOPFCodeGenerator.WriteUpdateVisitor(Strings : TStrings; Const ObjectClassName : String);
Var
C,S : String;
I : Integer;
begin
C:=Format('TUpdate%sVisitor',[StripType(ObjectClassName)]);
Addln(Strings,'{ %s }',[C]);
Addln(Strings);
// Init
S:=BeginInit(Strings,C);
Addln(Strings,'Query.SQL.Text:=SQLUpdateObject;');
DecIndent;
EndMethod(Strings,S);
// AcceptVisitor
S:=BeginAcceptVisitor(Strings,C,ObjectClassName);
AddLn(Strings,'Result:=Result and (Visited.ObjectState=posUpdate);');
DecIndent;
EndMethod(Strings,S);
// SetupParams
S:=BeginSetupParams(Strings,C,ObjectClassName,True);
Addln(Strings,'With Query do',[ObjectClassName]);
IncINdent;
try
Addln(Strings,'begin');
For I:=0 to Fields.Count-1 do
If Fields[i].Enabled then
WriteParamAssign(Strings,Fields[i]);
Addln(Strings,'end;');
finally
DecIndent;
end;
DecIndent;
EndMethod(Strings,S);
end;
{ ---------------------------------------------------------------------
List object commands
---------------------------------------------------------------------}
procedure TTiOPFCodeGenerator.DoCreateListDeclaration(Strings: TStrings;
const ObjectClassName, ListClassName, ListAncestorName: String);
begin
If caListItemsProperty in tiOPFOptions.ClassOptions then
begin
AddLn(Strings,'Private');
IncIndent;
Try
AddLn(Strings,'Function GetObj(Index : Integer) : %s;',[ObjectClassname]);
AddLn(Strings,'Procedure SetObj(Index : Integer; AValue : %s);',[ObjectClassname]);
Finally
DecIndent;
end;
end;
If (caListAddMethod in tiOPFOptions.ClassOptions) then
begin
AddLn(Strings,'Public');
IncIndent;
Try
Addln(Strings,'Procedure Add(AnItem : %s); reintroduce;',[ObjectClassName]);
Finally
DecIndent;
end;
end;
If (caListItemsProperty in tiOPFOptions.ClassOptions) then
begin
If Not (caListAddMethod in tiOPFOptions.ClassOptions) then
AddLn(Strings,'Public');
IncIndent;
Try
AddLn(Strings,'Property Items[Index : Integer] : %s Read GetObj Write SetObj; Default;',[ObjectClassname]);
Finally
DecIndent;
end;
end;
end;
procedure TTiOPFCodeGenerator.CreateListDeclaration(Strings: TStrings;
const ObjectClassName, ListClassName, ListAncestorName: String);
begin
Addln(Strings);
Addln(Strings,'{ %s }',[ListClassName]);
Addln(Strings);
Addln(Strings,'%s = Class(%s)',[ListClassName,ListAncestorName]);
DoCreateListDeclaration(Strings,ObjectClassName,ListClassName,ListAncestorName);
AddLn(Strings,'end;');
end;
procedure TTiOPFCodeGenerator.WriteListAddObject(Strings: TStrings;
const ListClassName, ObjectClassName: String);
Var
S : String;
begin
S:=Format('Procedure %s.Add(AnItem : %s);',[ListClassName,ObjectClassName]);
BeginMethod(Strings,S);
Addln(Strings,'begin');
IncIndent;
try
Addln(Strings,'inherited Add(AnItem);');
finally
DecIndent;
end;
EndMethod(Strings,S);
end;
procedure TTiOPFCodeGenerator.CreateListImplementation(Strings: TStrings; const ObjectClassName, ListClassName: String);
Var
S : String;
begin
If caListItemsProperty in tiOPFOptions.ClassOptions then
begin
AddLn(Strings,'{ %s }',[ListClassName]);
AddLn(Strings);
S:=Format('Function %s.GetObj(Index : Integer) : %s;',[ListClassName,ObjectClassname]);
BeginMethod(Strings,S);
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'Result:=%s(Inherited Items[Index]);',[ObjectClassname]);
finally
DecIndent;
end;
EndMethod(Strings,S);
S:=Format('Procedure %s.SetObj(Index : Integer; AValue : %s);',[ListClassName,ObjectClassname]);
BeginMethod(Strings,S);
AddLn(Strings,'begin');
IncIndent;
try
AddLn(Strings,'Inherited Items[Index]:=AValue;');
finally
DecIndent;
end;
EndMethod(Strings,S);
end;
end;
Initialization
RegisterCodeGenerator('tiOPF','tiOPF class and visitors for the data',TTiOPFCodeGenerator);
Finalization
UnRegisterCodeGenerator(TTiOPFCodeGenerator);
end.

1514
packages/fcl-db/src/codegen/fpddcodegen.pp Normal file
View File

File diff suppressed because it is too large Load Diff