paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 15:49:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Improvements to tiopf code generator, and build project for use with lazarus

Browse Source 
git-svn-id: trunk@11354 -
This commit is contained in:
michael 2008-07-10 09:08:40 +00:00
parent fffc05731c
commit c33657c0e0
5 changed files with 532 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -1161,6 +1161,8 @@ 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/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

224
packages/fcl-db/src/codegen/buildddcg.lpi Normal file
View File

@ -0,0 +1,224 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="6"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<TargetFileExt Value=""/>
<ActiveEditorIndexAtStart Value="1"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
<Language Value=""/>
<CharSet 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"/>
<CursorPos X="18" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="52"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="fpddpopcode.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddpopcode"/>
<UsageCount Value="52"/>
<SyntaxHighlighter Value="Text"/>
</Unit1>
<Unit2>
<Filename Value="fpcgcreatedbf.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpcgcreatedbf"/>
<UsageCount Value="52"/>
<SyntaxHighlighter Value="Text"/>
</Unit2>
<Unit3>
<Filename Value="fpcgdbcoll.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpcgdbcoll"/>
<UsageCount Value="52"/>
<SyntaxHighlighter Value="Text"/>
</Unit3>
<Unit4>
<Filename Value="fpcgsqlconst.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpcgsqlconst"/>
<UsageCount Value="52"/>
<SyntaxHighlighter Value="Text"/>
</Unit4>
<Unit5>
<Filename Value="fpcgtiopf.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpcgtiopf"/>
<CursorPos X="37" Y="474"/>
<TopLine Value="457"/>
<EditorIndex Value="1"/>
<UsageCount Value="52"/>
<Loaded Value="True"/>
</Unit5>
<Unit6>
<Filename Value="fpddcodegen.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="fpddcodegen"/>
<CursorPos X="3" Y="638"/>
<TopLine Value="635"/>
<EditorIndex Value="2"/>
<UsageCount Value="52"/>
<Loaded Value="True"/>
</Unit6>
</Units>
<JumpHistory Count="30" HistoryIndex="29">
<Position1>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="791" Column="1" TopLine="779"/>
</Position1>
<Position2>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position2>
<Position3>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="241" Column="38" TopLine="216"/>
</Position3>
<Position4>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="739" Column="56" TopLine="714"/>
</Position4>
<Position5>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="769" Column="36" TopLine="744"/>
</Position5>
<Position6>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="791" Column="34" TopLine="766"/>
</Position6>
<Position7>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="820" Column="32" TopLine="795"/>
</Position7>
<Position8>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="835" Column="32" TopLine="810"/>
</Position8>
<Position9>
<Filename Value="fpddcodegen.pp"/>
<Caret Line="235" Column="15" TopLine="210"/>
</Position9>
<Position10>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="124" Column="26" TopLine="124"/>
</Position10>
<Position11>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="888" Column="1" TopLine="839"/>
</Position11>
<Position12>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="715" Column="18" TopLine="693"/>
</Position12>
<Position13>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="59" Column="30" TopLine="34"/>
</Position13>
<Position14>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="417" Column="46" TopLine="392"/>
</Position14>
<Position15>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="205" Column="9" TopLine="192"/>
</Position15>
<Position16>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="820" Column="1" TopLine="796"/>
</Position16>
<Position17>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="821" Column="49" TopLine="795"/>
</Position17>
<Position18>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position18>
<Position19>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="79" Column="33" TopLine="54"/>
</Position19>
<Position20>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="819" Column="31" TopLine="795"/>
</Position20>
<Position21>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="376" Column="31" TopLine="362"/>
</Position21>
<Position22>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="882" Column="28" TopLine="839"/>
</Position22>
<Position23>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="881" Column="21" TopLine="842"/>
</Position23>
<Position24>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="16" Column="1" TopLine="1"/>
</Position24>
<Position25>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="881" Column="28" TopLine="842"/>
</Position25>
<Position26>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="882" Column="23" TopLine="842"/>
</Position26>
<Position27>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position27>
<Position28>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="79" Column="33" TopLine="54"/>
</Position28>
<Position29>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="883" Column="5" TopLine="842"/>
</Position29>
<Position30>
<Filename Value="fpcgtiopf.pp"/>
<Caret Line="1" Column="1" TopLine="1"/>
</Position30>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<UnitOutputDirectory Value="../../units/$(TARGETCPU)-$(TARGETOS)"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>

15
packages/fcl-db/src/codegen/buildddcg.lpr Normal file
View File

@ -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.

345
packages/fcl-db/src/codegen/fpcgtiopf.pp
View File

@ -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,6 +61,7 @@ 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);
@ -68,6 +69,8 @@ TYpe
procedure WriteParamAssign(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,8 @@ Var
V : TVisitorOption;
begin
inherited DoGenerateInterface(Strings);
If (caCreateClass in TiOPFOptions.ClassOptions) then
inherited DoGenerateInterface(Strings);
With TiOPFOptions do
begin
IncIndent;
@ -247,6 +255,109 @@ 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 (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;
end;
procedure TTiOPFCodeGenerator.DoGenerateImplementation(Strings: TStrings);
@ -254,9 +365,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 +422,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 +457,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,8 +477,12 @@ 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
WriteParamAssign(Strings,F)
else
AddLn(Strings,'// Set up as needed');
DecIndent;
EndMethod(Strings,S);
// MapRowToObject
@ -390,37 +511,40 @@ 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);
@ -435,37 +559,40 @@ 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]);
AddLn(Strings,R);
@ -478,17 +605,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;
OCN:=StripType(ObjectClassName);
CS:=Format('SQLReadList%s',[OCN]);
C:=Format('TRead%sVisitor',[StripType(LN)]);
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
@ -519,16 +648,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
@ -553,17 +684,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 +713,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
WriteParamAssign(Strings,F)
else
AddLn(Strings,'// Add parameter setup code here ');
DecIndent;
EndMethod(Strings,S);
end;
@ -581,16 +725,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
@ -630,8 +776,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 +787,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 +814,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 +824,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 +857,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

46
packages/fcl-db/src/codegen/fpddcodegen.pp
View File

@ -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);