472fee7c6b
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4645 8e941d3f-bd1b-0410-a28a-d453659cc2b4
3210 lines
101 KiB
ObjectPascal
3210 lines
101 KiB
ObjectPascal
{
|
|
This file is part of the Web Service Toolkit
|
|
Copyright (c) 2006-2014 by Inoussa OUEDRAOGO
|
|
|
|
This file is provide under modified LGPL licence
|
|
( the files COPYING.modifiedLGPL and COPYING.LGPL).
|
|
|
|
|
|
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.
|
|
}
|
|
|
|
{$INCLUDE wst_global.inc}
|
|
unit generator;
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils,
|
|
PasTree,
|
|
pascal_parser_intf, source_utils, wst_types, generatorbase;
|
|
|
|
const
|
|
sWST_EXTENSION = 'wst';
|
|
|
|
type
|
|
|
|
{ TProxyGenerator }
|
|
|
|
TProxyGenerator = class(TBaseGenerator)
|
|
Private
|
|
FDecStream : ISourceStream;
|
|
FDecProcStream : ISourceStream;
|
|
FImpStream : ISourceStream;
|
|
|
|
function GenerateClassName(AIntf : TPasElement):String;
|
|
|
|
procedure GenerateUnitHeader();
|
|
procedure GenerateUnitImplementationHeader();
|
|
procedure GenerateUnitImplementationFooter();
|
|
|
|
procedure GenerateProxyIntf(AIntf, AEasyIntf : TPasClassType; ABinding : TwstBinding);
|
|
procedure GenerateProxyImp(AIntf, AEasyIntf : TPasClassType; ABinding : TwstBinding);
|
|
|
|
function GetDestUnitName():string;
|
|
Public
|
|
constructor Create(
|
|
ASymTable : TwstPasTreeContainer;
|
|
ASrcMngr : ISourceManager
|
|
);
|
|
procedure Execute();override;
|
|
End;
|
|
|
|
{ TStubGenerator }
|
|
|
|
TBinderGenerator = class(TBaseGenerator)
|
|
Private
|
|
FDecStream : ISourceStream;
|
|
FImpStream : ISourceStream;
|
|
|
|
function GenerateClassName(AIntf : TPasElement):String;
|
|
|
|
procedure GenerateUnitHeader();
|
|
procedure GenerateUnitImplementationHeader();
|
|
procedure GenerateUnitImplementationFooter();
|
|
|
|
procedure GenerateIntf(AIntf : TPasClassType);
|
|
procedure GenerateImp(AIntf : TPasClassType);
|
|
|
|
function GetDestUnitName():string;
|
|
Public
|
|
constructor Create(
|
|
ASymTable : TwstPasTreeContainer;
|
|
ASrcMngr : ISourceManager
|
|
);
|
|
procedure Execute();override;
|
|
End;
|
|
|
|
{ TImplementationGenerator }
|
|
|
|
TImplementationGenerator = class(TBaseGenerator)
|
|
Private
|
|
FDecStream : ISourceStream;
|
|
FImpStream : ISourceStream;
|
|
|
|
function GenerateClassName(AIntf : TPasElement):String;
|
|
|
|
procedure GenerateUnitHeader();
|
|
procedure GenerateUnitImplementationHeader();
|
|
procedure GenerateUnitImplementationFooter();
|
|
|
|
procedure GenerateIntf(AIntf : TPasClassType);
|
|
procedure GenerateImp(AIntf : TPasClassType);
|
|
|
|
function GetDestUnitName():string;
|
|
Public
|
|
constructor Create(
|
|
ASymTable : TwstPasTreeContainer;
|
|
ASrcMngr : ISourceManager
|
|
);
|
|
procedure Execute();override;
|
|
End;
|
|
|
|
{ TInftGenerator }
|
|
|
|
TInftGenerator = class(TBaseGenerator)
|
|
private
|
|
FDecStream : ISourceStream;
|
|
FImpStream : ISourceStream;
|
|
FImpFirstStream : ISourceStream;
|
|
FImpTempStream : ISourceStream;
|
|
FImpLastStream : ISourceStream;
|
|
FRttiFunc : ISourceStream;
|
|
FFormOptions : string;
|
|
private
|
|
procedure WriteDocumentation(AElement : TPasElement);
|
|
procedure WriteDocIfEnabled(AElement : TPasElement);{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
// Array handling helper routines
|
|
procedure WriteObjectArray(ASymbol : TPasArrayType);
|
|
procedure WriteSimpleTypeArray(ASymbol : TPasArrayType);
|
|
procedure WriteObjectCollection(ASymbol : TPasArrayType);
|
|
private
|
|
function GenerateIntfName(AIntf : TPasElement):string;
|
|
|
|
procedure GenerateUnitHeader(const AIncludeTypeSection : Boolean);
|
|
procedure GenerateUnitImplementationHeader();
|
|
procedure GenerateUnitImplementationFooter();
|
|
|
|
procedure GenerateIntf(AIntf : TPasClassType);
|
|
procedure GenerateTypeAlias(ASymbol : TPasAliasType);
|
|
procedure GenerateClass(ASymbol : TPasClassType);
|
|
procedure GenerateEnum(ASymbol : TPasEnumType);
|
|
procedure GenerateArray(ASymbol : TPasArrayType);
|
|
procedure GenerateRecord(ASymbol : TPasRecordType);
|
|
|
|
procedure GenerateCustomMetadatas();
|
|
function GetDestUnitName():string;
|
|
|
|
procedure PrepareModule();
|
|
procedure InternalExecute();
|
|
public
|
|
procedure Execute();override;
|
|
end;
|
|
|
|
|
|
|
|
implementation
|
|
uses parserutils, Contnrs, logger_intf, xsd_consts, strutils;
|
|
|
|
const sLOCAL_TYPE_REGISTER_REFERENCE = 'typeRegistryInstance';
|
|
sPROXY_BASE_CLASS = 'TBaseProxy';
|
|
sBINDER_BASE_CLASS = 'TBaseServiceBinder';
|
|
sIMP_BASE_CLASS = 'TBaseServiceImplementation';
|
|
sSERIALIZER_CLASS = 'IFormatterClient';
|
|
//RETURN_PARAM_NAME = 'return';
|
|
RETURN_VAL_NAME = 'returnVal';
|
|
sNAME_SPACE = 'sNAME_SPACE';
|
|
sUNIT_NAME = 'sUNIT_NAME';
|
|
sRECORD_RTTI_DEFINE = 'WST_RECORD_RTTI';
|
|
sEASY_ACCESS_INTERFACE_PREFIX = 'Easy';
|
|
sARRAY_ITEM_DEFAULT_EXTERNAL_NAME = 'item';
|
|
|
|
sPRM_NAME = 'locStrPrmName';
|
|
sLOC_SERIALIZER = 'locSerializer';
|
|
sINPUT_PARAM = 'inputParam';
|
|
sOUTPUT_PARAM = 'outputParam';
|
|
sTEMP_OBJ = 'tmpObj';
|
|
sDOCUMENTATION = 'documentation';
|
|
sLOC_CALL_CONTEXT = 'locCallContext';
|
|
|
|
|
|
function DeduceEasyInterfaceForDocStyle(
|
|
const ARawInt : TPasClassType;
|
|
const AContainer : TwstPasTreeContainer
|
|
): TPasClassType;
|
|
|
|
function IsFinallyAClassType(const AElt : TPasElement) : Boolean;
|
|
begin
|
|
Result := ( AElt <> nil ) and
|
|
( AElt.InheritsFrom(TPasClassType) or
|
|
( AElt.InheritsFrom(TPasType) and
|
|
GetUltimeType(TPasType(AElt)).InheritsFrom(TPasClassType)
|
|
)
|
|
);
|
|
end;
|
|
|
|
function HandleProc(const AIntf : TPasClassType; const AMethod : TPasProcedure) : Boolean;
|
|
var
|
|
locMethod : TPasProcedure;
|
|
locProcType : TPasProcedureType;
|
|
locElt : TPasElement;
|
|
locRawInParam, locRawOutParam : TPasClassType;
|
|
k, q : Integer;
|
|
locProp, locResProp : TPasProperty;
|
|
locArg : TPasArgument;
|
|
locIsFunction : Boolean;
|
|
begin
|
|
Result := False;
|
|
if ( AMethod.ProcType.Args.Count < 1 ) then
|
|
Exit;
|
|
locElt := TPasArgument(AMethod.ProcType.Args[0]).ArgType;
|
|
if locElt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
locElt := AContainer.FindElement(locElt.Name);
|
|
if ( locElt = nil ) then
|
|
Exit;
|
|
if not IsFinallyAClassType(locElt) then
|
|
Exit;
|
|
locRawInParam := TPasClassType(GetUltimeType(TPasType(locElt)));
|
|
locIsFunction := False;
|
|
if AMethod.InheritsFrom(TPasFunction) then begin
|
|
locElt := TPasFunctionType(AMethod.ProcType).ResultEl.ResultType;
|
|
if locElt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
locElt := AContainer.FindElement(locElt.Name);
|
|
if not IsFinallyAClassType(locElt) then
|
|
Exit;
|
|
locRawOutParam := TPasClassType(GetUltimeType(TPasType(locElt)));
|
|
q := locRawOutParam.Members.Count;
|
|
if ( q > 0 ) then begin
|
|
for k := 0 to ( q - 1 ) do begin
|
|
if TPasElement(locRawOutParam.Members[k]).InheritsFrom(TPasProperty) then begin
|
|
locProp := TPasProperty(locRawOutParam.Members[k]);
|
|
if ( locProp.Visibility = visPublished ) then begin
|
|
locResProp := locProp;
|
|
locIsFunction := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if locIsFunction then begin
|
|
locMethod := TPasFunction(AContainer.CreateElement(TPasFunction,AMethod.Name,AIntf,'',0));
|
|
locMethod.ProcType := TPasFunctionType(AContainer.CreateElement(TPasFunctionType,AMethod.ProcType.Name,locMethod,'',0));
|
|
end else begin
|
|
locMethod := TPasProcedure(AContainer.CreateElement(TPasProcedure,AMethod.Name,AIntf,'',0));
|
|
locMethod.ProcType := TPasProcedureType(AContainer.CreateElement(TPasProcedureType,AMethod.ProcType.Name,locMethod,'',0));
|
|
end;
|
|
AIntf.Members.Add(locMethod);
|
|
q := locRawInParam.Members.Count;
|
|
locProcType := locMethod.ProcType;
|
|
if ( q > 0 ) then begin
|
|
for k := 0 to ( q - 1 ) do begin
|
|
locElt := TPasElement(locRawInParam.Members[k]);
|
|
if locElt.InheritsFrom(TPasProperty) then begin
|
|
locProp := TPasProperty(locElt);
|
|
if ( locProp.Visibility = visPublished ) then begin
|
|
locArg := TPasArgument(AContainer.CreateElement(TPasArgument,locProp.Name,locProcType,'',0));
|
|
locArg.ArgType := locProp.VarType;
|
|
locArg.ArgType.AddRef();
|
|
locArg.Access := argConst;
|
|
locProcType.Args.Add(locArg);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
if locIsFunction then begin
|
|
TPasFunctionType(locProcType).ResultEl := TPasResultElement(AContainer.CreateElement(TPasResultElement,'Result',locProcType,'',0));
|
|
TPasFunctionType(locProcType).ResultEl.ResultType := locResProp.VarType; locResProp.VarType.AddRef();
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
var
|
|
locRes : TPasClassType;
|
|
i, c : Integer;
|
|
g : TGuid;
|
|
e : TPasElement;
|
|
procCount : Integer;
|
|
locName : string;
|
|
begin
|
|
if ( ARawInt.ObjKind <> okInterface ) then
|
|
raise Exception.CreateFmt('Interface expected : "%s".',[ARawInt.Name]);
|
|
locName := Format('%s%s',[ARawInt.Name,sEASY_ACCESS_INTERFACE_PREFIX]);
|
|
e := AContainer.FindElement(locName);
|
|
if (e <> nil) then begin
|
|
Result := e as TPasClassType;
|
|
Exit;
|
|
end;
|
|
procCount := 0;
|
|
locRes := TPasClassType(
|
|
AContainer.CreateElement(
|
|
TPasClassType,
|
|
Format('%s%s',[ARawInt.Name,sEASY_ACCESS_INTERFACE_PREFIX]),
|
|
AContainer.CurrentModule.InterfaceSection,'',0
|
|
)
|
|
);
|
|
try
|
|
locRes.ObjKind := okInterface;
|
|
if ( CreateGUID(g) = 0 ) then
|
|
{$IFDEF HAS_EXP_TREE}
|
|
locRes.GUIDExpr:=TPrimitiveExpr.Create(locRes,pekString,GUIDToString(g));
|
|
{$ELSE HAS_EXP_TREE}
|
|
locRes.InterfaceGUID := GUIDToString(g);
|
|
{$ENDIF HAS_EXP_TREE}
|
|
c := ARawInt.Members.Count;
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to ( c - 1 ) do begin
|
|
e := TPasElement(ARawInt.Members[i]);
|
|
if e.InheritsFrom(TPasProcedure) and
|
|
HandleProc(locRes,TPasProcedure(e))
|
|
then
|
|
Inc(procCount);
|
|
end;
|
|
end;
|
|
if ( procCount = 0 ) then
|
|
FreeAndNil(locRes);
|
|
except
|
|
FreeAndNil(locRes);
|
|
raise;
|
|
end;
|
|
Result := locRes;
|
|
end;
|
|
|
|
{ TProxyGenerator }
|
|
|
|
function TProxyGenerator.GenerateClassName(AIntf: TPasElement): String;
|
|
begin
|
|
Result := ExtractserviceName(AIntf);
|
|
Result := Format('T%s_Proxy',[Result]);
|
|
end;
|
|
|
|
procedure TProxyGenerator.GenerateUnitHeader();
|
|
var
|
|
s : string;
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
WriteLn('{');
|
|
WriteLn('This unit has been produced by ws_helper.');
|
|
WriteLn(' Input unit name : "%s".',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' This unit name : "%s".',[GetDestUnitName()]);
|
|
WriteLn(' Date : "%s".',[DateTimeToStr(Now())]);
|
|
WriteLn('}');
|
|
WriteLn('');
|
|
WriteLn('Unit %s;',[GetDestUnitName()]);
|
|
WriteLn('{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}');
|
|
WriteLn('Interface');
|
|
WriteLn('');
|
|
|
|
s := GenerateExtraUses();
|
|
if IsStrEmpty(s) then begin
|
|
WriteLn('Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, %s;',[SymbolTable.CurrentModule.Name]);
|
|
end else begin
|
|
WriteLn('Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, %s,',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' ' + s + ';');
|
|
end;
|
|
WriteLn('');
|
|
WriteLn('Type');
|
|
WriteLn('');
|
|
end;
|
|
|
|
procedure TProxyGenerator.GenerateUnitImplementationHeader();
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
WriteLn('');
|
|
WriteLn('Implementation');
|
|
WriteLn('uses wst_resources_imp, metadata_repository;');
|
|
end;
|
|
|
|
procedure TProxyGenerator.GenerateUnitImplementationFooter();
|
|
var
|
|
s :string;
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
NewLine();
|
|
WriteLn('initialization');
|
|
WriteLn(' {$i %s.%s}',[SymbolTable.CurrentModule.Name,sWST_EXTENSION]);
|
|
NewLine();
|
|
s := Format('Register_%s_ServiceMetadata',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' {$IF DECLARED(%s)}',[s]);
|
|
WriteLn(' %s();',[s]);
|
|
WriteLn(' {$IFEND}');
|
|
WriteLn('End.');
|
|
end;
|
|
|
|
constructor TProxyGenerator.Create(
|
|
ASymTable : TwstPasTreeContainer;
|
|
ASrcMngr : ISourceManager
|
|
);
|
|
begin
|
|
Inherited Create(ASymTable,ASrcMngr);
|
|
FDecStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec');
|
|
FDecProcStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec_proc');
|
|
FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp');
|
|
end;
|
|
|
|
procedure TProxyGenerator.Execute();
|
|
Var
|
|
i,c : Integer;
|
|
intf : TPasClassType;
|
|
elt : TPasElement;
|
|
ls : TList2;
|
|
binding : TwstBinding;
|
|
intfEasy : TPasClassType;
|
|
HandleEasyIntf : Boolean;
|
|
begin
|
|
HandleEasyIntf := ( goDocumentWrappedParameter in Self.Options );
|
|
GenerateUnitHeader();
|
|
GenerateUnitImplementationHeader();
|
|
ls := SymbolTable.CurrentModule.InterfaceSection.Declarations;
|
|
c := Pred(ls.Count);
|
|
if HandleEasyIntf then begin
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(ls[i]);
|
|
if ( elt is TPasClassType ) and ( TPasClassType(elt).ObjKind = okInterface ) then begin
|
|
intf := elt as TPasClassType;
|
|
binding := SymbolTable.FindBinding(intf);
|
|
intfEasy := nil;
|
|
if ( binding.BindingStyle = bsDocument ) then begin
|
|
if (binding.EasyIntf = nil) then begin
|
|
binding.EasyIntf := DeduceEasyInterfaceForDocStyle(intf,SymbolTable);
|
|
if (binding.EasyIntf <> nil) then
|
|
binding.EasyIntf.Release();
|
|
end;
|
|
intfEasy := binding.EasyIntf;
|
|
end;
|
|
GenerateProxyIntf(intf,intfEasy,binding);
|
|
GenerateProxyImp(intf,intfEasy,binding);
|
|
end;
|
|
end;
|
|
end else begin
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(ls[i]);
|
|
if ( elt is TPasClassType ) and ( TPasClassType(elt).ObjKind = okInterface ) then begin
|
|
intf := elt as TPasClassType;
|
|
GenerateProxyIntf(intf,nil,binding);
|
|
GenerateProxyImp(intf,nil,binding);
|
|
end;
|
|
end;
|
|
end;
|
|
GenerateUnitImplementationFooter();
|
|
SrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FDecProcStream,FImpStream]);
|
|
FDecStream := nil;
|
|
FImpStream := nil;
|
|
end;
|
|
|
|
function TProxyGenerator.GetDestUnitName(): string;
|
|
begin
|
|
Result := Format('%s_proxy',[SymbolTable.CurrentModule.Name]);
|
|
end;
|
|
|
|
procedure TProxyGenerator.GenerateProxyIntf(AIntf, AEasyIntf : TPasClassType; ABinding : TwstBinding);
|
|
var
|
|
HandleEasyIntf : boolean;
|
|
|
|
procedure WriteDec();
|
|
var
|
|
locModule : TPasModule;
|
|
begin
|
|
locModule := FindModule(AIntf);
|
|
if (locModule = nil) then
|
|
locModule := SymbolTable.CurrentModule;
|
|
Indent();
|
|
Write('%s=class(%s,%s.%s',[GenerateClassName(AIntf),sPROXY_BASE_CLASS, locModule.Name, AIntf.Name]);
|
|
if HandleEasyIntf then begin
|
|
locModule := FindModule(AIntf);
|
|
if (locModule = nil) then
|
|
locModule := SymbolTable.CurrentModule;
|
|
Write(',%s.%s',[locModule.Name, AEasyIntf.Name]);
|
|
end;
|
|
WriteLn(')');
|
|
FDecProcStream.IncIndent();
|
|
try
|
|
FDecProcStream.NewLine();
|
|
FDecProcStream.Indent();
|
|
FDecProcStream.WriteLn('Function wst_CreateInstance_%s(const AFormat : string = %s; const ATransport : string = %s; const AAddress : string = ''''):%s;',[AIntf.Name,QuotedStr('SOAP:'),QuotedStr('HTTP:'),AIntf.Name]);
|
|
if HandleEasyIntf then begin
|
|
FDecProcStream.Indent();
|
|
FDecProcStream.WriteLn(
|
|
'Function wst_CreateInstance_%s%s(const AFormat : string = %s; const ATransport : string = %s; const AAddress : string = ''''):%s%s;',
|
|
[AIntf.Name,sEASY_ACCESS_INTERFACE_PREFIX,QuotedStr('SOAP:'),QuotedStr('HTTP:'),AIntf.Name,sEASY_ACCESS_INTERFACE_PREFIX]
|
|
);
|
|
end;
|
|
finally
|
|
FDecProcStream.DecIndent();
|
|
end;
|
|
end;
|
|
|
|
procedure WriteMethod(AMthd : TPasProcedure);
|
|
Var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
prms : TList2;
|
|
Begin
|
|
Indent();
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write('function ')
|
|
end else begin
|
|
Write('procedure ')
|
|
end;
|
|
Write('%s(',[AMthd.Name]);
|
|
|
|
If ( prmCnt > 0 ) Then Begin
|
|
IncIndent();
|
|
For k := 0 To Pred(prmCnt) Do Begin
|
|
prm := TPasArgument(prms[k]);
|
|
If (k > 0 ) Then
|
|
Write('; ');
|
|
NewLine();
|
|
Indent();
|
|
Write('%s %s : %s',[AccessNames[prm.Access],prm.Name,prm.ArgType.Name]);
|
|
End;
|
|
DecIndent();
|
|
NewLine();
|
|
Indent();
|
|
End;
|
|
|
|
Write(')');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write(':%s',[TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
Write(';');
|
|
if HandleEasyIntf then
|
|
Write('overload;');
|
|
WriteLn('');
|
|
End;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mthds : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) = 0 ) then
|
|
Exit;
|
|
Indent();
|
|
WriteLn('Protected');
|
|
IncIndent();
|
|
Indent();WriteLn('class function GetServiceType() : PTypeInfo;override;');
|
|
mthds := AIntf.Members;
|
|
for k := 0 to Pred(mthds.Count) do begin
|
|
elt := TPasElement(mthds[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethod(TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
if HandleEasyIntf then begin
|
|
Indent(); WriteLn('// Easy acces methods');
|
|
mthds := AEasyIntf.Members;
|
|
for k := 0 to Pred(mthds.Count) do begin
|
|
elt := TPasElement(mthds[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethod(TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
end;
|
|
|
|
begin
|
|
HandleEasyIntf := ( goDocumentWrappedParameter in Self.Options ) and ( AEasyIntf <> nil );
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
IncIndent();
|
|
WriteDec();
|
|
WriteMethods();
|
|
Indent(); WriteLn('End;');
|
|
DecIndent();
|
|
end;
|
|
|
|
procedure TProxyGenerator.GenerateProxyImp(AIntf, AEasyIntf : TPasClassType; ABinding : TwstBinding);
|
|
Var
|
|
strClassName : String;
|
|
HandleEasyIntf : Boolean;
|
|
|
|
procedure WriteDec();
|
|
begin
|
|
NewLine();
|
|
WriteLn('Function wst_CreateInstance_%s(const AFormat : string; const ATransport : string; const AAddress : string):%s;',[AIntf.Name,AIntf.Name]);
|
|
WriteLn('Var');
|
|
IncIndent();
|
|
Indent(); WriteLn('locAdr : string;');
|
|
DecIndent();
|
|
WriteLn('Begin');
|
|
IncIndent();
|
|
Indent(); WriteLn('locAdr := AAddress;');
|
|
Indent(); WriteLn('if ( locAdr = '''' ) then');
|
|
IncIndent();
|
|
Indent(); WriteLn('locAdr := GetServiceDefaultAddress(TypeInfo(%s));',[AIntf.Name]);
|
|
DecIndent();
|
|
Indent();
|
|
WriteLn(
|
|
'Result := %s.Create(%s,AFormat+%s,ATransport + %s);',
|
|
[ strClassName,QuotedStr(AIntf.Name),
|
|
Format('GetServiceDefaultFormatProperties(TypeInfo(%s))',[AIntf.Name]),
|
|
QuotedStr('address=') + ' + locAdr'
|
|
]
|
|
);
|
|
DecIndent();
|
|
WriteLn('End;');
|
|
NewLine();
|
|
|
|
if HandleEasyIntf then begin
|
|
WriteLn(
|
|
'Function wst_CreateInstance_%s%s(const AFormat : string; const ATransport : string; const AAddress : string):%s%s;',
|
|
[AIntf.Name,sEASY_ACCESS_INTERFACE_PREFIX,AIntf.Name,sEASY_ACCESS_INTERFACE_PREFIX]
|
|
);
|
|
WriteLn('Begin');
|
|
IncIndent();
|
|
Indent();
|
|
WriteLn(
|
|
'Result := wst_CreateInstance_%s(AFormat,ATransport,AAddress) as %s%s;',
|
|
[AIntf.Name,AIntf.Name,sEASY_ACCESS_INTERFACE_PREFIX]
|
|
);
|
|
DecIndent();
|
|
WriteLn('End;');
|
|
NewLine();
|
|
end;
|
|
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) > 0 ) then
|
|
WriteLn('{ %s implementation }',[strClassName]);
|
|
end;
|
|
|
|
procedure WriteMethodDec(AMthd : TPasProcedure);
|
|
Var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
prms : TList2;
|
|
Begin
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write('function ')
|
|
end else begin
|
|
Write('procedure ');
|
|
end;
|
|
Write('%s.%s(',[strClassName,AMthd.Name]);
|
|
|
|
If ( prmCnt > 0 ) Then Begin
|
|
IncIndent();
|
|
For k := 0 To Pred(prmCnt) Do Begin
|
|
prm := TPasArgument(prms[k]);
|
|
If (k > 0 ) Then
|
|
Write('; ');
|
|
NewLine();
|
|
Indent();
|
|
Write('%s %s : %s',[AccessNames[prm.Access],prm.Name,prm.ArgType.Name]);
|
|
End;
|
|
DecIndent();
|
|
NewLine();
|
|
Indent();
|
|
End;
|
|
|
|
Write(')');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write(':%s',[TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
WriteLn(';');
|
|
End;
|
|
|
|
procedure WriteEasyMethodImp(AMthd : TPasProcedure);
|
|
var
|
|
prms : TList2;
|
|
origineRes : TPasResultElement;
|
|
origineResProp : TPasProperty;
|
|
|
|
function HasObjectsArgs() : Boolean;
|
|
var
|
|
k : Integer;
|
|
prm : TPasArgument;
|
|
elt : TPasElement;
|
|
begin
|
|
Result := False;
|
|
for k := 0 to ( prms.Count - 1 ) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
elt := prm.ArgType;
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(elt));
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Result := True;
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure AssignArguments();
|
|
var
|
|
k : Integer;
|
|
prm : TPasArgument;
|
|
elt : TPasElement;
|
|
begin
|
|
for k := 0 to ( prms.Count - 1 ) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
elt := prm.ArgType;
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(elt));
|
|
|
|
if SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('%s := %s.%s;',[sTEMP_OBJ,sINPUT_PARAM,prm.Name]);
|
|
Indent(); WriteLn('%s.%s := nil;',[sINPUT_PARAM,prm.Name]);
|
|
Indent(); WriteLn('%s.Free();',[sTEMP_OBJ]);
|
|
end else if SymbolTable.IsOfType(TPasType(elt),TPasUnresolvedTypeRef) then begin
|
|
WriteLn('{$IF SizeOf(%s) = SizeOf(Pointer)}',[elt.Name]);
|
|
Indent(); WriteLn('if ( PTypeInfo(TypeInfo(%s))^.Kind = tkClass ) then begin',[elt.Name]);
|
|
IncIndent();
|
|
Indent(); WriteLn('%s := TObject(%s.%s);',[sTEMP_OBJ,sINPUT_PARAM,prm.Name]);
|
|
Indent(); WriteLn('%s.Free();',[sTEMP_OBJ]);
|
|
Indent(); WriteLn('TObject(%s.%s) := nil;',[sINPUT_PARAM,prm.Name]);
|
|
DecIndent();
|
|
WriteLn('{$IFEND}');
|
|
Indent(); WriteLn('end;');
|
|
end;
|
|
Indent(); WriteLn('%s.%s := %s;',[sINPUT_PARAM,prm.Name,prm.Name]);
|
|
end;
|
|
end;
|
|
|
|
procedure ClearArguments();
|
|
var
|
|
k : Integer;
|
|
prm : TPasArgument;
|
|
elt : TPasElement;
|
|
begin
|
|
for k := 0 to ( prms.Count - 1 ) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
elt := prm.ArgType;
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(elt));
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
Indent(); WriteLn('if ( PTypeInfo(TypeInfo(%s))^.Kind = tkClass ) then',[elt.Name]);
|
|
IncIndent();
|
|
Indent(); WriteLn('TObject(%s.%s) := nil;',[sINPUT_PARAM,prm.Name]);
|
|
DecIndent();
|
|
end else begin
|
|
if SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('%s.%s := nil;',[sINPUT_PARAM,prm.Name]);
|
|
end;
|
|
end;
|
|
end;
|
|
if AMthd.ProcType.InheritsFrom(TPasFunctionType) then begin
|
|
elt := origineResProp.VarType;
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(elt));
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
Indent(); WriteLn('if ( PTypeInfo(TypeInfo(%s))^.Kind = tkClass ) then',[elt.Name]);
|
|
IncIndent();
|
|
Indent(); WriteLn('if ( %s <> nil ) then',[sOUTPUT_PARAM]);
|
|
IncIndent();
|
|
Indent(); WriteLn('TObject(%s.%s) := nil;',[sOUTPUT_PARAM,origineResProp.Name]);
|
|
DecIndent();
|
|
DecIndent();
|
|
end else begin
|
|
if SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('if ( %s <> nil ) then',[sOUTPUT_PARAM]);
|
|
IncIndent();
|
|
Indent(); WriteLn('%s.%s := nil;',[sOUTPUT_PARAM,origineResProp.Name]);
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
origineMthd : TPasProcedure;
|
|
origineIsFunc : Boolean;
|
|
origineArgIN : TPasArgument;
|
|
prmCnt,k : Integer;
|
|
elt : TPasElement;
|
|
objArgs : Boolean;
|
|
localIsFunc : boolean;
|
|
origineResultType : TPasClassType;
|
|
begin
|
|
origineMthd := FindMember(AIntf,AMthd.Name) as TPasProcedure;
|
|
Assert ( origineMthd <> nil );
|
|
origineArgIN := TPasArgument(origineMthd.ProcType.Args[0]);
|
|
origineIsFunc := origineMthd.InheritsFrom(TPasFunction);
|
|
origineResProp := nil;
|
|
localIsFunc := AMthd.InheritsFrom(TPasFunction);
|
|
if origineIsFunc then begin
|
|
origineRes := TPasFunctionType(origineMthd.ProcType).ResultEl;
|
|
origineResultType := GetUltimeType(TPasType(origineRes.ResultType)) as TPasClassType;
|
|
for k := 0 to (origineResultType.Members.Count - 1) do begin
|
|
elt := TPasElement(origineResultType.Members[k]);
|
|
if elt.InheritsFrom(TPasProperty) and ( TPasProperty(elt).Visibility = visPublished ) then begin
|
|
origineResProp := TPasProperty(elt);
|
|
Break;
|
|
end;
|
|
end;
|
|
Assert( localIsFunc or ( origineResProp = nil ) );
|
|
end else begin
|
|
origineRes := nil;
|
|
end;
|
|
prms := AMthd.ProcType.Args;
|
|
objArgs := HasObjectsArgs();
|
|
IncIndent();
|
|
WriteLn('var');
|
|
Indent(); WriteLn('%s : TObject;',[sTEMP_OBJ]);
|
|
Indent(); WriteLn('%s : %s;',[sINPUT_PARAM,origineArgIN.ArgType.Name]);
|
|
if origineIsFunc then begin
|
|
Indent(); WriteLn('%s : %s;',[sOUTPUT_PARAM,origineRes.ResultType.Name]);
|
|
end;
|
|
WriteLn('begin');
|
|
Indent(); WriteLn('%s := nil;',[sOUTPUT_PARAM]);
|
|
Indent(); WriteLn('%s := %s.Create();',[sINPUT_PARAM,origineArgIN.ArgType.Name]);
|
|
Indent(); WriteLn('try');
|
|
IncIndent();
|
|
prmCnt := prms.Count;
|
|
if ( prmCnt > 0 ) then
|
|
AssignArguments();
|
|
if objArgs then begin
|
|
Indent(); WriteLn('try');
|
|
IncIndent();
|
|
end;
|
|
if origineIsFunc then begin
|
|
Indent(); WriteLn('%s := %s(%s);',[sOUTPUT_PARAM,origineMthd.Name,sINPUT_PARAM]);
|
|
if localIsFunc then begin
|
|
elt := origineResProp.VarType;
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(elt));
|
|
Indent(); WriteLn('if ( %s <> nil ) then begin',[sOUTPUT_PARAM]);
|
|
IncIndent();
|
|
Indent(); WriteLn('Result := %s.%s;',[sOUTPUT_PARAM,origineResProp.Name]);
|
|
if SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('%s.%s := nil;',[sOUTPUT_PARAM,origineResProp.Name]);
|
|
end;
|
|
DecIndent();
|
|
Indent(); WriteLn('end else begin');
|
|
IncIndent();
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
Indent(); WriteLn('FillChar(Result,SizeOf(Result),#0);');
|
|
end else begin
|
|
if SymbolTable.IsOfType(TPasType(elt),TPasClassType) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('Result := nil;');
|
|
end else begin
|
|
Indent(); WriteLn('FillChar(Result,SizeOf(Result),#0);');
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
Indent(); WriteLn('end;');
|
|
end;
|
|
end else begin
|
|
Indent(); WriteLn('%s(%s);',[origineMthd.Name,sINPUT_PARAM]);
|
|
end;
|
|
if objArgs then begin
|
|
DecIndent();
|
|
Indent(); WriteLn('finally');
|
|
IncIndent();
|
|
ClearArguments();
|
|
DecIndent();
|
|
Indent(); WriteLn('end;');
|
|
end;
|
|
DecIndent();
|
|
Indent(); WriteLn('finally');
|
|
IncIndent();
|
|
Indent(); WriteLn('FreeAndNil(%s);',[sINPUT_PARAM]);
|
|
Indent(); WriteLn('FreeAndNil(%s);',[sOUTPUT_PARAM]);
|
|
DecIndent();
|
|
Indent(); WriteLn('end;');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
|
|
procedure WriteMethodImp(AMthd : TPasProcedure);
|
|
Var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
resPrm : TPasResultElement;
|
|
prms : TList2;
|
|
Begin
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
IncIndent();
|
|
WriteLn('Var');
|
|
|
|
Indent();WriteLn('%s : %s;',[sLOC_SERIALIZER,sSERIALIZER_CLASS]);
|
|
Indent();WriteLn('%s : ICallContext;',[sLOC_CALL_CONTEXT]);
|
|
if ( prmCnt > 0 ) or AMthd.InheritsFrom(TPasFunction) then begin
|
|
Indent();WriteLn('%s : %s;',[sPRM_NAME,'string']);
|
|
end;
|
|
|
|
WriteLn('Begin');
|
|
|
|
Indent();WriteLn('%s := Self as ICallContext;',[sLOC_CALL_CONTEXT]);
|
|
Indent();WriteLn('%s := GetSerializer();',[sLOC_SERIALIZER]);
|
|
Indent();WriteLn('Try');IncIndent();
|
|
|
|
Indent();WriteLn('%s.BeginCall(''%s'', GetTarget(),%s);',[sLOC_SERIALIZER,SymbolTable.GetExternalName(AMthd),sLOC_CALL_CONTEXT]);
|
|
IncIndent();
|
|
for k := 0 To Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
If ( prm.Access <> argOut ) Then Begin
|
|
Indent();WriteLn('%s.Put(%s, TypeInfo(%s), %s);',[sLOC_SERIALIZER,QuotedStr(SymbolTable.GetExternalName(prm)),prm.ArgType.Name,prm.Name]);
|
|
End;
|
|
End;
|
|
DecIndent();
|
|
Indent();WriteLn('%s.EndCall();',[sLOC_SERIALIZER]);
|
|
|
|
WriteLn('');
|
|
Indent();WriteLn('MakeCall();');
|
|
WriteLn('');
|
|
|
|
Indent();WriteLn('%s.BeginCallRead(%s);',[sLOC_SERIALIZER,sLOC_CALL_CONTEXT]);
|
|
IncIndent();
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
resPrm := TPasFunctionType(AMthd.ProcType).ResultEl;
|
|
if SymbolTable.IsInitNeed(resPrm.ResultType) then begin
|
|
if SymbolTable.IsOfType(resPrm.ResultType,TPasClassType) or
|
|
SymbolTable.IsOfType(resPrm.ResultType,TPasArrayType)
|
|
then begin
|
|
Indent();WriteLn('Result := Nil;');
|
|
end;
|
|
end;
|
|
Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(SymbolTable.GetExternalName(resPrm))]);
|
|
Indent();WriteLn('%s.Get(TypeInfo(%s), %s, %s);',[sLOC_SERIALIZER,resPrm.ResultType.Name,sPRM_NAME,'Result']);
|
|
end;
|
|
//--------------------------------
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if ( prm.Access = argOut ) then begin
|
|
if SymbolTable.IsInitNeed(prm.ArgType) then begin
|
|
if SymbolTable.IsOfType(prm.ArgType,TPasClassType) or
|
|
SymbolTable.IsOfType(prm.ArgType,TPasArrayType)
|
|
then begin
|
|
Indent();WriteLn('%s := Nil;',[prm.Name]);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
//--------------------------------
|
|
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if ( prm.Access in [argVar, argOut] ) then begin
|
|
Indent();WriteLn('%s := %s;',[sPRM_NAME,QuotedStr(SymbolTable.GetExternalName(prm))]);
|
|
Indent();WriteLn('%s.Get(TypeInfo(%s), %s, %s);',[sLOC_SERIALIZER,prm.ArgType.Name,sPRM_NAME,prm.Name]);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
|
|
|
|
WriteLn('');
|
|
DecIndent();
|
|
Indent();WriteLn('Finally');
|
|
IncIndent();
|
|
Indent();WriteLn('%s.Clear();',[sLOC_SERIALIZER]);
|
|
DecIndent();
|
|
Indent();WriteLn('End;');DecIndent();
|
|
|
|
WriteLn('End;');
|
|
end;
|
|
|
|
procedure WriteTypeInfoMethod();
|
|
var
|
|
locModule : TPasModule;
|
|
begin
|
|
locModule := FindModule(AIntf);
|
|
if (locModule = nil) then
|
|
locModule := SymbolTable.CurrentModule;
|
|
NewLine();
|
|
WriteLn('class function %s.GetServiceType() : PTypeInfo;',[strClassName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent(); WriteLn('result := TypeInfo(%s.%s);',[locModule.Name, AIntf.Name]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
NewLine();
|
|
end;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mthds : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
WriteTypeInfoMethod();
|
|
mthds := AIntf.Members;
|
|
for k := 0 to Pred(mthds.Count) do begin
|
|
elt := TPasElement(mthds[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethodDec(TPasProcedure(elt));
|
|
WriteMethodImp(TPasProcedure(elt));
|
|
WriteLn('');
|
|
end;
|
|
end;
|
|
if HandleEasyIntf then begin
|
|
mthds := AEasyIntf.Members;
|
|
if ( mthds.Count > 0 ) then begin
|
|
for k := 0 to Pred(mthds.Count) do begin
|
|
elt := TPasElement(mthds[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethodDec(TPasProcedure(elt));
|
|
WriteEasyMethodImp(TPasProcedure(elt));
|
|
WriteLn('');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
HandleEasyIntf := ( goDocumentWrappedParameter in Self.Options ) and ( AEasyIntf <> nil );
|
|
SetCurrentStream(FImpStream);
|
|
IncIndent();
|
|
While ( DecIndent() > 0 ) Do
|
|
;
|
|
strClassName := GenerateClassName(AIntf);
|
|
NewLine();
|
|
WriteDec();
|
|
WriteMethods();
|
|
end;
|
|
|
|
{ TBinderGenerator }
|
|
|
|
function TBinderGenerator.GenerateClassName(AIntf: TPasElement): String;
|
|
begin
|
|
Result := ExtractserviceName(AIntf);
|
|
Result := Format('T%s_ServiceBinder',[Result]);
|
|
end;
|
|
|
|
procedure TBinderGenerator.GenerateUnitHeader();
|
|
var
|
|
s : string;
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
WriteLn('{');
|
|
WriteLn('This unit has been produced by ws_helper.');
|
|
WriteLn(' Input unit name : "%s".',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' This unit name : "%s".',[GetDestUnitName()]);
|
|
WriteLn(' Date : "%s".',[DateTimeToStr(Now())]);
|
|
WriteLn('}');
|
|
|
|
WriteLn('unit %s;',[GetDestUnitName()]);
|
|
WriteLn('{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}');
|
|
WriteLn('interface');
|
|
WriteLn('');
|
|
|
|
s := GenerateExtraUses();
|
|
if IsStrEmpty(s) then begin
|
|
WriteLn('uses SysUtils, Classes, base_service_intf, server_service_intf, %s;',[SymbolTable.CurrentModule.Name]);
|
|
end else begin
|
|
WriteLn('uses SysUtils, Classes, base_service_intf, server_service_intf, %s,',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' ' + s + ';');
|
|
end;
|
|
WriteLn('');
|
|
end;
|
|
|
|
procedure TBinderGenerator.GenerateUnitImplementationHeader();
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
WriteLn('');
|
|
WriteLn('Implementation');
|
|
WriteLn('uses TypInfo, wst_resources_imp,metadata_repository;');
|
|
end;
|
|
|
|
procedure TBinderGenerator.GenerateUnitImplementationFooter();
|
|
var
|
|
s :string;
|
|
begin
|
|
NewLine();
|
|
WriteLn('initialization');
|
|
NewLine();
|
|
WriteLn(' {$i %s.%s}',[SymbolTable.CurrentModule.Name,sWST_EXTENSION]);
|
|
NewLine();
|
|
s := Format('Register_%s_ServiceMetadata',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' {$IF DECLARED(%s)}',[s]);
|
|
WriteLn(' %s();',[s]);
|
|
WriteLn(' {$IFEND}');
|
|
NewLine();
|
|
WriteLn('End.');
|
|
end;
|
|
|
|
procedure TBinderGenerator.GenerateIntf(AIntf: TPasClassType);
|
|
procedure WriteDec();
|
|
begin
|
|
WriteLn('type');
|
|
Indent();
|
|
WriteLn('%s = class(%s)',[GenerateClassName(AIntf),sBINDER_BASE_CLASS]);
|
|
end;
|
|
|
|
procedure WriteConstructor();
|
|
Begin
|
|
Indent();
|
|
WriteLn('constructor Create();')
|
|
End;
|
|
|
|
procedure WriteMethod(AMthd : TPasProcedure);
|
|
Begin
|
|
Indent();
|
|
WriteLn('procedure %sHandler(AFormatter : IFormatterResponse; AContext : ICallContext);',[AMthd.Name])
|
|
End;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mbrs : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) > 0 ) then begin
|
|
Indent();WriteLn('protected');
|
|
IncIndent();
|
|
mbrs := AIntf.Members;
|
|
for k := 0 to Pred(mbrs.Count) do begin
|
|
elt := TPasElement(mbrs[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethod(TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
|
|
Indent();WriteLn('public');
|
|
Indent();WriteConstructor();
|
|
end;
|
|
end;
|
|
|
|
procedure GenerateFactoryClass();
|
|
Begin
|
|
NewLine();
|
|
WriteLn('type');
|
|
IncIndent();BeginAutoIndent();
|
|
WriteLn('T%s_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)',[ExtractserviceName(AIntf)]);
|
|
WriteLn('private');
|
|
IncIndent();
|
|
WriteLn('FInstance : IInterface;');
|
|
DecIndent();
|
|
|
|
WriteLn('protected');
|
|
IncIndent();
|
|
WriteLn('function CreateInstance():IInterface;');
|
|
DecIndent();
|
|
|
|
WriteLn('public');
|
|
IncIndent();
|
|
WriteLn('constructor Create();');
|
|
WriteLn('destructor Destroy();override;');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
DecIndent();EndAutoIndent();
|
|
End;
|
|
|
|
procedure GenerateRegistrationProc();
|
|
Begin
|
|
NewLine();
|
|
BeginAutoIndent();
|
|
IncIndent();
|
|
WriteLn('procedure Server_service_Register%sService();',[ExtractserviceName(AIntf)]);
|
|
DecIndent();
|
|
EndAutoIndent();
|
|
End;
|
|
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
IncIndent();
|
|
WriteDec();
|
|
WriteMethods();
|
|
Indent();WriteLn('end;');
|
|
DecIndent();
|
|
|
|
GenerateFactoryClass();
|
|
GenerateRegistrationProc();
|
|
end;
|
|
|
|
procedure TBinderGenerator.GenerateImp(AIntf: TPasClassType);
|
|
Var
|
|
strClassName : String;
|
|
|
|
procedure WriteDec();
|
|
begin
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) > 0 ) then
|
|
WriteLn('{ %s implementation }',[strClassName]);
|
|
end;
|
|
|
|
procedure WriteMethodDec(AMthd : TPasProcedure);
|
|
Begin
|
|
WriteLn('procedure %s.%sHandler(AFormatter : IFormatterResponse; AContext : ICallContext);',[strClassName,AMthd.Name]);
|
|
End;
|
|
|
|
procedure WriteMethodImp(AMthd : TPasProcedure);
|
|
Var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
prms : TList2;
|
|
resElt : TPasResultElement;
|
|
strBuff : string;
|
|
Begin
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
WriteLn('var');
|
|
IncIndent();BeginAutoIndent();
|
|
WriteLn('cllCntrl : ICallControl;');
|
|
WriteLn('objCntrl : IObjectControl;');
|
|
WriteLn('hasObjCntrl : Boolean;');
|
|
WriteLn('tmpObj : %s;',[AIntf.Name]);
|
|
WriteLn('callCtx : ICallContext;');
|
|
if ( prmCnt > 0 ) or AMthd.InheritsFrom(TPasFunction) then begin
|
|
WriteLn('%s : string;',[sPRM_NAME]);
|
|
end;
|
|
WriteLn('procName,trgName : string;');
|
|
if ( prmCnt > 0 ) then begin
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
WriteLn('%s : %s;',[prm.Name,prm.ArgType.Name]);
|
|
end;
|
|
end;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
WriteLn('%s : %s;',[RETURN_VAL_NAME,TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
DecIndent();EndAutoIndent();
|
|
|
|
WriteLn('begin');
|
|
IncIndent();BeginAutoIndent();
|
|
|
|
WriteLn('callCtx := AContext;');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
resElt := TPasFunctionType(AMthd.ProcType).ResultEl;
|
|
if SymbolTable.IsInitNeed(resElt.ResultType) then
|
|
WriteLn('%s := nil;',[RETURN_VAL_NAME]);
|
|
end;
|
|
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if SymbolTable.IsInitNeed(prm.ArgType) then
|
|
WriteLn('%s := nil;',[prm.Name]);
|
|
end;
|
|
|
|
NewLine();
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
Write('%s := %s;',[sPRM_NAME,QuotedStr(SymbolTable.GetExternalName(prm))]);
|
|
WriteLn('AFormatter.Get(TypeInfo(%s),%s,%s);',[prm.ArgType.Name,sPRM_NAME,prm.Name]);
|
|
if SymbolTable.IsInitNeed(prm.ArgType) then begin
|
|
if SymbolTable.IsOfType(prm.ArgType,TPasClassType) or SymbolTable.IsOfType(prm.ArgType,TPasArrayType) then begin
|
|
WriteLn('if (%s <> nil) then',[prm.Name]);
|
|
IncIndent();
|
|
WriteLn('callCtx.AddObjectToFree(%s);',[prm.Name]);
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
NewLine();
|
|
WriteLn('tmpObj := Self.GetFactory().CreateInstance() as %s;',[AIntf.Name]);
|
|
WriteLn('if Supports(tmpObj,ICallControl,cllCntrl) then');
|
|
Indent();WriteLn('cllCntrl.SetCallContext(callCtx);');
|
|
WriteLn('hasObjCntrl := Supports(tmpObj,IObjectControl,objCntrl);');
|
|
WriteLn('if hasObjCntrl then');
|
|
Indent();WriteLn('objCntrl.Activate();');
|
|
|
|
WriteLn('try');IncIndent();
|
|
|
|
if AMthd.InheritsFrom(TPasFunction) then
|
|
Write('%s := tmpObj.%s(',[RETURN_VAL_NAME,AMthd.Name])
|
|
else
|
|
Write('tmpObj.%s(',[AMthd.Name]);
|
|
strBuff := '';
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
strBuff := strBuff + Format('%s,',[prm.Name]);
|
|
end;
|
|
if ( prmCnt > 0 ) then
|
|
Delete(strBuff,Length(strBuff),1);
|
|
strBuff := strBuff + ');';
|
|
EndAutoIndent();
|
|
WriteLn(strBuff);
|
|
BeginAutoIndent();
|
|
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
if SymbolTable.IsInitNeed(resElt.ResultType) then begin
|
|
WriteLn('if (%s <> nil) then',[RETURN_VAL_NAME]);
|
|
IncIndent();
|
|
WriteLn('callCtx.AddObjectToFree(%s);',[RETURN_VAL_NAME]);
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
NewLine();
|
|
|
|
WriteLn('procName := AFormatter.GetCallProcedureName();');
|
|
WriteLn('trgName := AFormatter.GetCallTarget();');
|
|
WriteLn('AFormatter.Clear();');
|
|
|
|
WriteLn('AFormatter.BeginCallResponse(procName,trgName);');
|
|
IncIndent();
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(SymbolTable.GetExternalName(resElt)),resElt.ResultType.Name,RETURN_VAL_NAME]);
|
|
end;
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if ( prm.Access in [argOut,argVar] ) then
|
|
WriteLn('AFormatter.Put(%s,TypeInfo(%s),%s);',[QuotedStr(SymbolTable.GetExternalName(prm)),prm.ArgType.Name,prm.Name]);
|
|
end;
|
|
DecIndent();
|
|
WriteLn('AFormatter.EndCallResponse();');
|
|
NewLine();
|
|
WriteLn('callCtx := nil;');
|
|
|
|
DecIndent();
|
|
WriteLn('finally');
|
|
WriteLn(' if hasObjCntrl then');
|
|
WriteLn(' objCntrl.Deactivate();');
|
|
WriteLn(' Self.GetFactory().ReleaseInstance(tmpObj);');
|
|
WriteLn('end;');
|
|
|
|
DecIndent();EndAutoIndent();
|
|
WriteLn('end;');
|
|
End;
|
|
|
|
procedure WriteConstructor();
|
|
Var
|
|
k : Integer;
|
|
mtd : TPasProcedure;
|
|
mtds : TList2;
|
|
Begin
|
|
NewLine();
|
|
WriteLn('constructor %s.Create();',[strClassName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
BeginAutoIndent();
|
|
WriteLn('inherited Create(GetServiceImplementationRegistry().FindFactory(%s));',[QuotedStr(AIntf.Name)]);
|
|
mtds := AIntf.Members;
|
|
for k := 0 to Pred(mtds.Count) do begin
|
|
if TPasElement(mtds[k]).InheritsFrom(TPasProcedure) then begin
|
|
mtd := TPasProcedure(mtds[k]);
|
|
WriteLn(
|
|
'RegisterVerbHandler(%s,{$IFDEF FPC}@{$ENDIF}%sHandler);',
|
|
[QuotedStr(SymbolTable.GetExternalName(mtd)),mtd.Name]);
|
|
end;
|
|
end;
|
|
EndAutoIndent();
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
NewLine();
|
|
End;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mtds : TList2;
|
|
mtd : TPasProcedure;
|
|
begin
|
|
mtds := AIntf.Members;
|
|
for k := 0 to Pred(mtds.Count) do begin
|
|
if TPasElement(mtds[k]).InheritsFrom(TPasProcedure) then begin
|
|
mtd := TPasProcedure(mtds[k]);
|
|
WriteMethodDec(mtd);
|
|
WriteMethodImp(mtd);
|
|
WriteLn('');
|
|
end;
|
|
end;
|
|
WriteConstructor();
|
|
end;
|
|
|
|
procedure GenerateFactoryClass();
|
|
Var
|
|
strBuff : string;
|
|
Begin
|
|
NewLine();
|
|
BeginAutoIndent();
|
|
strBuff := Format('T%s_ServiceBinderFactory',[ExtractserviceName(AIntf)]);
|
|
WriteLn('{ %s }',[strBuff]);
|
|
NewLine();
|
|
WriteLn('function %s.CreateInstance():IInterface;',[strBuff]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
WriteLn('Result := FInstance;',[strClassName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('constructor %s.Create();',[strBuff]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
WriteLn('FInstance := %s.Create() as IInterface;',[strClassName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('destructor %s.Destroy();',[strBuff]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
WriteLn('FInstance := nil;');
|
|
WriteLn('inherited Destroy();');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
EndAutoIndent();
|
|
End;
|
|
|
|
procedure GenerateRegistrationProc();
|
|
Var
|
|
strBuff : string;
|
|
Begin
|
|
NewLine();
|
|
BeginAutoIndent();
|
|
strBuff := ExtractserviceName(AIntf);
|
|
NewLine();
|
|
WriteLn('procedure Server_service_Register%sService();',[strBuff]);
|
|
WriteLn('Begin');
|
|
IncIndent();
|
|
WriteLn(
|
|
'GetServerServiceRegistry().Register(%s,T%s_ServiceBinderFactory.Create() as IItemFactory);',
|
|
[QuotedStr(SymbolTable.GetExternalName(AIntf)),strBuff]
|
|
);
|
|
DecIndent();
|
|
WriteLn('End;');
|
|
EndAutoIndent();
|
|
End;
|
|
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
IncIndent();
|
|
While ( DecIndent() > 0 ) Do
|
|
;
|
|
strClassName := GenerateClassName(AIntf);
|
|
NewLine();
|
|
WriteDec();
|
|
WriteMethods();
|
|
|
|
GenerateFactoryClass();
|
|
GenerateRegistrationProc();
|
|
end;
|
|
|
|
function TBinderGenerator.GetDestUnitName(): string;
|
|
begin
|
|
Result := Format('%s_binder',[SymbolTable.CurrentModule.Name]);
|
|
end;
|
|
|
|
constructor TBinderGenerator.Create(ASymTable: TwstPasTreeContainer;ASrcMngr: ISourceManager);
|
|
begin
|
|
Inherited Create(ASymTable,ASrcMngr);
|
|
FDecStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec');
|
|
FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp');
|
|
end;
|
|
|
|
procedure TBinderGenerator.Execute();
|
|
Var
|
|
i,c : Integer;
|
|
intf : TPasClassType;
|
|
typeList : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
GenerateUnitHeader();
|
|
GenerateUnitImplementationHeader();
|
|
typeList := SymbolTable.CurrentModule.InterfaceSection.Declarations;
|
|
c := Pred(typeList.Count);
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasClassType) and ( TPasClassType(elt).ObjKind = okInterface ) then begin
|
|
intf := TPasClassType(elt);
|
|
GenerateIntf(intf);
|
|
GenerateImp(intf);
|
|
end;
|
|
end;
|
|
GenerateUnitImplementationFooter();
|
|
SrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FImpStream]);
|
|
FDecStream := nil;
|
|
FImpStream := nil;
|
|
end;
|
|
|
|
{ TImplementationGenerator }
|
|
|
|
function TImplementationGenerator.GenerateClassName(AIntf: TPasElement): String;
|
|
begin
|
|
Result := ExtractserviceName(AIntf);
|
|
Result := Format('T%s_ServiceImp',[Result]);
|
|
end;
|
|
|
|
procedure TImplementationGenerator.GenerateUnitHeader();
|
|
var
|
|
s : string;
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
WriteLn('{');
|
|
WriteLn('This unit has been produced by ws_helper.');
|
|
WriteLn(' Input unit name : "%s".',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' This unit name : "%s".',[GetDestUnitName()]);
|
|
WriteLn(' Date : "%s".',[DateTimeToStr(Now())]);
|
|
WriteLn('}');
|
|
|
|
WriteLn('Unit %s;',[GetDestUnitName()]);
|
|
WriteLn('{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}');
|
|
WriteLn('Interface');
|
|
WriteLn('');
|
|
|
|
s := GenerateExtraUses();
|
|
WriteLn('Uses SysUtils, Classes, ');
|
|
if IsStrEmpty(s) then begin
|
|
WriteLn(' base_service_intf, server_service_intf, server_service_imputils, %s;',[SymbolTable.CurrentModule.Name]);
|
|
end else begin
|
|
WriteLn(' base_service_intf, server_service_intf, server_service_imputils, %s,',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' ' + s + ';');
|
|
end;
|
|
WriteLn('');
|
|
end;
|
|
|
|
procedure TImplementationGenerator.GenerateUnitImplementationHeader();
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
WriteLn('');
|
|
WriteLn('Implementation');
|
|
WriteLn('uses config_objects;');
|
|
end;
|
|
|
|
procedure TImplementationGenerator.GenerateUnitImplementationFooter();
|
|
begin
|
|
NewLine();
|
|
WriteLn('End.');
|
|
end;
|
|
|
|
procedure TImplementationGenerator.GenerateIntf(AIntf: TPasClassType);
|
|
procedure WriteDec();
|
|
begin
|
|
Indent();
|
|
WriteLn('%s=class(%s,%s)',[GenerateClassName(AIntf),sIMP_BASE_CLASS,AIntf.Name]);
|
|
end;
|
|
|
|
procedure WriteMethod(AMthd : TPasProcedure);
|
|
var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
prms : TList2;
|
|
begin
|
|
Indent();
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write('function ')
|
|
end else begin
|
|
Write('procedure ');
|
|
end;
|
|
Write('%s(',[AMthd.Name]);
|
|
|
|
if ( prmCnt > 0 ) then begin
|
|
IncIndent();
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if (k > 0 ) then
|
|
Write('; ');
|
|
NewLine();
|
|
Indent();
|
|
Write('%s %s : %s',[AccessNames[prm.Access],prm.Name,prm.ArgType.Name]);
|
|
end;
|
|
DecIndent();
|
|
NewLine();
|
|
Indent();
|
|
end;
|
|
|
|
Write(')');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write(':%s',[TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
WriteLn(';');
|
|
end;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mtds : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) > 0 ) then begin
|
|
Indent();WriteLn('Protected');
|
|
IncIndent();
|
|
mtds := AIntf.Members;
|
|
for k := 0 to Pred(mtds.Count) do begin
|
|
elt := TPasElement(mtds[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethod(TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
|
|
procedure GenerateRegistrationProc();
|
|
Begin
|
|
NewLine();
|
|
BeginAutoIndent();
|
|
IncIndent();
|
|
WriteLn('procedure Register%sImplementationFactory();',[ExtractserviceName(AIntf)]);
|
|
DecIndent();
|
|
EndAutoIndent();
|
|
End;
|
|
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteLn('type');
|
|
IncIndent();
|
|
WriteDec();
|
|
WriteMethods();
|
|
Indent(); WriteLn('End;');
|
|
NewLine();
|
|
DecIndent();
|
|
|
|
GenerateRegistrationProc();
|
|
end;
|
|
|
|
procedure TImplementationGenerator.GenerateImp(AIntf: TPasClassType);
|
|
var
|
|
strClassName : String;
|
|
|
|
procedure WriteDec();
|
|
begin
|
|
if ( GetElementCount(AIntf.Members,TPasProcedure) > 0 ) then begin
|
|
WriteLn('{ %s implementation }',[strClassName]);
|
|
end;
|
|
end;
|
|
|
|
procedure WriteMethodDec(AMthd : TPasProcedure);
|
|
var
|
|
prmCnt,k : Integer;
|
|
prms : TList2;
|
|
prm : TPasArgument;
|
|
begin
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write('function ');
|
|
end else begin
|
|
Write('procedure ');
|
|
end;
|
|
Write('%s.%s(',[strClassName,AMthd.Name]);
|
|
|
|
if ( prmCnt > 0 ) then begin
|
|
IncIndent();
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if (k > 0 ) then
|
|
Write('; ');
|
|
NewLine();
|
|
Indent();
|
|
Write('%s %s : %s',[AccessNames[prm.Access],prm.Name,prm.ArgType.Name]);
|
|
end;
|
|
DecIndent();
|
|
NewLine();
|
|
Indent();
|
|
end;
|
|
|
|
Write(')');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write(':%s',[TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
WriteLn(';');
|
|
end;
|
|
|
|
procedure WriteMethodImp(AMthd : TPasProcedure);
|
|
begin
|
|
WriteLn('Begin');
|
|
WriteLn('// your code here');
|
|
WriteLn('End;');
|
|
end;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mbrs : TList2;
|
|
elt : TPasElement;
|
|
mtd : TPasProcedure;
|
|
begin
|
|
mbrs := AIntf.Members;
|
|
for k := 0 to Pred(mbrs.Count) do begin
|
|
elt := TPasElement(mbrs[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
mtd := TPasProcedure(elt);
|
|
WriteMethodDec(mtd);
|
|
WriteMethodImp(mtd);
|
|
WriteLn('');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure GenerateRegistrationProc();
|
|
var
|
|
strBuff, locClassName, locInterfName : string;
|
|
Begin
|
|
NewLine();
|
|
BeginAutoIndent();
|
|
strBuff := ExtractserviceName(AIntf);
|
|
locClassName := strClassName;
|
|
locInterfName := QuotedStr(AIntf.Name);
|
|
NewLine();
|
|
WriteLn('procedure Register%sImplementationFactory();',[strBuff]);
|
|
WriteLn('Begin');
|
|
IncIndent();
|
|
strBuff := Format(
|
|
'GetServiceImplementationRegistry().Register(' +
|
|
'%s,' +
|
|
'TImplementationFactory.Create(' +
|
|
'%s,wst_GetServiceConfigText(%s)' +
|
|
') as IServiceImplementationFactory);',
|
|
[locInterfName,locClassName,locInterfName]
|
|
);
|
|
WriteLn(strBuff);
|
|
DecIndent();
|
|
WriteLn('End;');
|
|
EndAutoIndent();
|
|
End;
|
|
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
IncIndent();
|
|
While ( DecIndent() > 0 ) Do
|
|
;
|
|
strClassName := GenerateClassName(AIntf);
|
|
NewLine();
|
|
WriteDec();
|
|
WriteMethods();
|
|
|
|
GenerateRegistrationProc();
|
|
end;
|
|
|
|
function TImplementationGenerator.GetDestUnitName(): string;
|
|
begin
|
|
Result := Format('%s_imp',[SymbolTable.CurrentModule.Name]);
|
|
end;
|
|
|
|
constructor TImplementationGenerator.Create(ASymTable: TwstPasTreeContainer;ASrcMngr: ISourceManager);
|
|
begin
|
|
Inherited Create(ASymTable,ASrcMngr);
|
|
FDecStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec');
|
|
FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp');
|
|
end;
|
|
|
|
procedure TImplementationGenerator.Execute();
|
|
Var
|
|
i,c : Integer;
|
|
intf : TPasClassType;
|
|
elt : TPasElement;
|
|
typeList : TList2;
|
|
begin
|
|
GenerateUnitHeader();
|
|
GenerateUnitImplementationHeader();
|
|
typeList := SymbolTable.CurrentModule.InterfaceSection.Declarations;
|
|
c := Pred(typeList.Count);
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasClassType) and ( TPasClassType(elt).ObjKind = okInterface ) then begin
|
|
intf := TPasClassType(elt);
|
|
GenerateIntf(intf);
|
|
GenerateImp(intf);
|
|
end;
|
|
end;
|
|
GenerateUnitImplementationFooter();
|
|
SrcMngr.Merge(GetDestUnitName() + '.pas',[FDecStream,FImpStream]);
|
|
FDecStream := nil;
|
|
FImpStream := nil;
|
|
end;
|
|
|
|
{ TInftGenerator }
|
|
|
|
procedure TInftGenerator.WriteDocumentation(AElement : TPasElement);
|
|
var
|
|
pl : TStrings;
|
|
docString : string;
|
|
i : Integer;
|
|
begin
|
|
pl := SymbolTable.Properties.FindList(AElement);
|
|
if ( pl <> nil ) then begin
|
|
i := pl.IndexOfName(sDOCUMENTATION);
|
|
if ( i >= 0 ) then begin
|
|
docString:= StringReplace(DecodeLineBreak(pl.ValueFromIndex[i]),#10,sLineBreak,[rfReplaceAll]);
|
|
if not IsStrEmpty(docString) then begin
|
|
WriteLn('{ %s',[AElement.Name]);
|
|
WriteLn(docString);
|
|
WriteLn('}');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.WriteDocIfEnabled(AElement : TPasElement);
|
|
begin
|
|
if ( goGenerateDocAsComments in Options ) then
|
|
WriteDocumentation(AElement);
|
|
end;
|
|
|
|
procedure TInftGenerator.WriteObjectArray(ASymbol : TPasArrayType);
|
|
var
|
|
locElementTypeName : string;
|
|
begin
|
|
locElementTypeName := FindActualType(ASymbol.ElType,SymbolTable).Name;
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
BeginAutoIndent();
|
|
try
|
|
WriteLn('%s = class(TBaseObjectArrayRemotable)',[ASymbol.Name]);
|
|
WriteLn('private');
|
|
Indent();WriteLn('function GetItem(AIndex: Integer): %s;',[locElementTypeName]);
|
|
WriteLn('public');
|
|
Indent();WriteLn('class function GetItemClass():TBaseRemotableClass;override;');
|
|
Indent();WriteLn('property Item[AIndex:Integer] : %s Read GetItem;Default;',[locElementTypeName]);
|
|
WriteLn('end;');
|
|
finally
|
|
EndAutoIndent();
|
|
DecIndent();
|
|
end;
|
|
|
|
SetCurrentStream(FImpStream);
|
|
NewLine();
|
|
WriteLn('{ %s }',[ASymbol.Name]);
|
|
|
|
NewLine();
|
|
WriteLn('function %s.GetItem(AIndex: Integer): %s;',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := %s(Inherited GetItem(AIndex));',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('class function %s.GetItemClass(): TBaseRemotableClass;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result:= %s;',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
|
|
procedure TInftGenerator.WriteSimpleTypeArray(ASymbol : TPasArrayType);
|
|
var
|
|
locElementTypeName : string;
|
|
begin
|
|
locElementTypeName := FindActualType(ASymbol.ElType,SymbolTable).Name;
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
BeginAutoIndent();
|
|
try
|
|
WriteLn('%s = class(TBaseSimpleTypeArrayRemotable)',[ASymbol.Name]);
|
|
WriteLn('private');
|
|
Indent();WriteLn('FData : array of %s;',[locElementTypeName]);
|
|
WriteLn('private');
|
|
Indent();WriteLn('function GetItem(AIndex: Integer): %s;',[locElementTypeName]);
|
|
Indent();WriteLn('procedure SetItem(AIndex: Integer; const AValue: %s);',[locElementTypeName]);
|
|
WriteLn('protected');
|
|
Indent();WriteLn('function GetLength():Integer;override;');
|
|
Indent();WriteLn('procedure SaveItem(AStore : IFormatterBase;const AName : String;const AIndex : Integer);override;');
|
|
Indent();WriteLn('procedure LoadItem(AStore : IFormatterBase;const AIndex : Integer);override;');
|
|
WriteLn('public');
|
|
Indent();WriteLn('class function GetItemTypeInfo():PTypeInfo;override;');
|
|
Indent();WriteLn('procedure SetLength(const ANewSize : Integer);override;');
|
|
Indent();WriteLn('procedure Assign(Source: TPersistent); override;');
|
|
Indent();WriteLn('property Item[AIndex:Integer] : %s read GetItem write SetItem; default;',[locElementTypeName]);
|
|
WriteLn('end;');
|
|
finally
|
|
EndAutoIndent();
|
|
DecIndent();
|
|
end;
|
|
|
|
SetCurrentStream(FImpStream);
|
|
NewLine();
|
|
WriteLn('{ %s }',[ASymbol.Name]);
|
|
|
|
NewLine();
|
|
WriteLn('function %s.GetItem(AIndex: Integer): %s;',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('CheckIndex(AIndex);');
|
|
Indent();WriteLn('Result := FData[AIndex];');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('procedure %s.SetItem(AIndex: Integer;const AValue: %S);',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('CheckIndex(AIndex);');
|
|
Indent();WriteLn('FData[AIndex] := AValue;');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('function %s.GetLength(): Integer;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := System.Length(FData);');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('procedure %s.SaveItem(AStore: IFormatterBase;const AName: String; const AIndex: Integer);',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('AStore.Put(%s,TypeInfo(%s),FData[AIndex]);',[QuotedStr(SymbolTable.GetArrayItemName(ASymbol)),locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
IncIndent();
|
|
WriteLn('procedure %s.LoadItem(AStore: IFormatterBase;const AIndex: Integer);',[ASymbol.Name]);
|
|
WriteLn('var');
|
|
Indent();WriteLn('sName : string;');
|
|
WriteLn('begin');
|
|
Indent();WriteLn('sName := %s;',[QuotedStr(SymbolTable.GetArrayItemName(ASymbol))]);
|
|
Indent();WriteLn('AStore.Get(TypeInfo(%s),sName,FData[AIndex]);',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('class function %s.GetItemTypeInfo(): PTypeInfo;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := TypeInfo(%s);',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
IncIndent();
|
|
WriteLn('procedure %s.SetLength(const ANewSize: Integer);',[ASymbol.Name]);
|
|
WriteLn('var');
|
|
Indent();WriteLn('i : Integer;');
|
|
WriteLn('begin');
|
|
Indent();WriteLn('if ( ANewSize < 0 ) then');
|
|
Indent();Indent();WriteLn('i := 0');
|
|
Indent();WriteLn('else');
|
|
Indent();Indent();WriteLn('i := ANewSize;');
|
|
Indent();WriteLn('System.SetLength(FData,i);');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
IncIndent();
|
|
WriteLn('procedure %s.Assign(Source: TPersistent);',[ASymbol.Name]);
|
|
WriteLn('var');
|
|
Indent();WriteLn('src : %s;',[ASymbol.Name]);
|
|
Indent();WriteLn('i, c : Integer;');
|
|
WriteLn('begin');
|
|
Indent();WriteLn('if Assigned(Source) and Source.InheritsFrom(%s) then begin',[ASymbol.Name]);
|
|
IncIndent();
|
|
Indent();WriteLn('src := %s(Source);',[ASymbol.Name]);
|
|
Indent();WriteLn('c := src.Length;');
|
|
Indent();WriteLn('Self.SetLength(c);');
|
|
Indent();WriteLn('if ( c > 0 ) then begin');
|
|
IncIndent();
|
|
Indent();WriteLn('for i := 0 to Pred(c) do begin');
|
|
IncIndent(); Indent(); WriteLn('Self[i] := src[i];'); DecIndent();
|
|
Indent();WriteLn('end;');
|
|
DecIndent();
|
|
Indent();WriteLn('end;');
|
|
DecIndent();
|
|
Indent();WriteLn('end else begin');
|
|
IncIndent(); Indent(); WriteLn('inherited Assign(Source);'); DecIndent();
|
|
Indent();WriteLn('end;');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
|
|
procedure TInftGenerator.WriteObjectCollection(ASymbol : TPasArrayType);
|
|
var
|
|
locElementTypeName : string;
|
|
begin
|
|
locElementTypeName := FindActualType(ASymbol.ElType,SymbolTable).Name;
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
BeginAutoIndent();
|
|
try
|
|
WriteLn('%s = class(TObjectCollectionRemotable)',[ASymbol.Name]);
|
|
WriteLn('private');
|
|
Indent();WriteLn('function GetItem(AIndex: Integer): %s;',[locElementTypeName]);
|
|
WriteLn('public');
|
|
Indent();WriteLn('class function GetItemClass():TBaseRemotableClass;override;');
|
|
Indent();WriteLn('function Add(): %s; {$IFDEF USE_INLINE}inline;{$ENDIF}',[locElementTypeName]);
|
|
Indent();WriteLn('function AddAt(const APosition : Integer) : %s; {$IFDEF USE_INLINE}inline;{$ENDIF}',[locElementTypeName]);
|
|
Indent();WriteLn('property Item[AIndex:Integer] : %s Read GetItem;Default;',[locElementTypeName]);
|
|
WriteLn('end;');
|
|
finally
|
|
EndAutoIndent();
|
|
DecIndent();
|
|
end;
|
|
|
|
SetCurrentStream(FImpStream);
|
|
NewLine();
|
|
WriteLn('{ %s }',[ASymbol.Name]);
|
|
|
|
NewLine();
|
|
WriteLn('function %s.GetItem(AIndex: Integer): %s;',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := %s(Inherited GetItem(AIndex));',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('class function %s.GetItemClass(): TBaseRemotableClass;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result:= %s;',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('function %s.Add() : %s;',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := %s(inherited Add());',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('function %s.AddAt(const APosition : Integer) : %s;',[ASymbol.Name,locElementTypeName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := %s(inherited AddAt(APosition));',[locElementTypeName]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
|
|
function TInftGenerator.GenerateIntfName(AIntf: TPasElement): string;
|
|
begin
|
|
Result := AIntf.Name;//ExtractserviceName(AIntf);
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateUnitHeader(const AIncludeTypeSection : Boolean);
|
|
var
|
|
s : string;
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
WriteLn('{');
|
|
WriteLn('This unit has been produced by ws_helper.');
|
|
WriteLn(' Input unit name : "%s".',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn(' This unit name : "%s".',[GetDestUnitName()]);
|
|
WriteLn(' Date : "%s".',[DateTimeToStr(Now())]);
|
|
WriteLn('}');
|
|
|
|
WriteLn('unit %s;',[GetDestUnitName()]);
|
|
WriteLn('{$IFDEF FPC}');
|
|
WriteLn(' {$mode objfpc} {$H+}');
|
|
WriteLn('{$ENDIF}');
|
|
WriteLn('{$DEFINE WST_RECORD_RTTI}');
|
|
WriteLn('interface');
|
|
WriteLn('');
|
|
s := GenerateExtraUses();
|
|
if IsStrEmpty(s) then begin
|
|
WriteLn('uses SysUtils, Classes, TypInfo, base_service_intf, service_intf;');
|
|
end else begin
|
|
WriteLn('uses SysUtils, Classes, TypInfo, base_service_intf, service_intf,');
|
|
WriteLn(' ' + s + ';');
|
|
end;
|
|
IncIndent();
|
|
WriteLn('');
|
|
WriteLn('const');
|
|
Indent();WriteLn('sNAME_SPACE = %s;',[QuotedStr(SymbolTable.GetExternalName(SymbolTable.CurrentModule))]);
|
|
Indent();WriteLn('sUNIT_NAME = %s;',[QuotedStr(SymbolTable.CurrentModule.Name)]);
|
|
DecIndent();
|
|
|
|
if AIncludeTypeSection then begin
|
|
WriteLn('');
|
|
WriteLn('type');
|
|
WriteLn('');
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateUnitImplementationHeader();
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
WriteLn('');
|
|
WriteLn('Implementation');
|
|
WriteLn('uses metadata_repository, record_rtti, wst_types;');
|
|
FImpFirstStream.WriteLn('var');
|
|
FImpFirstStream.Indent();
|
|
FImpFirstStream.WriteLn('%s : TTypeRegistry = nil;',[sLOCAL_TYPE_REGISTER_REFERENCE]);
|
|
FImpFirstStream.WriteLn('initialization');
|
|
FImpFirstStream.Indent();
|
|
FImpFirstStream.WriteLn('%s := GetTypeRegistry();',[sLOCAL_TYPE_REGISTER_REFERENCE]);
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateUnitImplementationFooter();
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
NewLine();
|
|
NewLine();
|
|
FImpTempStream.NewLine();
|
|
FImpLastStream.NewLine();
|
|
FImpLastStream.WriteLn('End.');
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateIntf(AIntf: TPasClassType);
|
|
|
|
procedure WriteDec();
|
|
begin
|
|
Indent();
|
|
WriteLn('%s = interface(IInvokable)',[GenerateIntfName(AIntf)]);
|
|
if not IsStrEmpty(AIntf.InterfaceGUID) then begin
|
|
Indent();Indent();WriteLn('[%s]',[QuotedStr(AIntf.InterfaceGUID)]);
|
|
end;
|
|
end;
|
|
|
|
procedure WriteMethod(AMthd : TPasProcedure);
|
|
var
|
|
prmCnt,k : Integer;
|
|
prm : TPasArgument;
|
|
prms : TList2;
|
|
begin
|
|
Indent();
|
|
prms := AMthd.ProcType.Args;
|
|
prmCnt := prms.Count;
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write('function ');
|
|
end else begin
|
|
Write('procedure ');
|
|
end;
|
|
Write('%s(',[AMthd.Name]);
|
|
|
|
if ( prmCnt > 0 ) then begin
|
|
IncIndent();
|
|
for k := 0 to Pred(prmCnt) do begin
|
|
prm := TPasArgument(prms[k]);
|
|
if (k > 0 ) then
|
|
Write('; ');
|
|
NewLine();
|
|
Indent();
|
|
Write('%s %s : %s',[AccessNames[prm.Access],prm.Name,prm.ArgType.Name]);
|
|
end;
|
|
DecIndent();
|
|
NewLine();
|
|
Indent();
|
|
end;
|
|
|
|
Write(')');
|
|
if AMthd.InheritsFrom(TPasFunction) then begin
|
|
Write(':%s',[TPasFunctionType(AMthd.ProcType).ResultEl.ResultType.Name]);
|
|
end;
|
|
WriteLn(';');
|
|
end;
|
|
|
|
procedure WriteMethods();
|
|
var
|
|
k : Integer;
|
|
mbrs : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
IncIndent();
|
|
mbrs := AIntf.Members;
|
|
for k := 0 to Pred(mbrs.Count) do begin
|
|
elt := TPasElement(mbrs[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteMethod(TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
end;
|
|
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
IncIndent();
|
|
WriteDec();
|
|
WriteMethods();
|
|
Indent(); WriteLn('end;');
|
|
DecIndent();
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateTypeAlias(ASymbol: TPasAliasType);
|
|
var
|
|
typeModifier : string;
|
|
begin
|
|
try
|
|
SetCurrentStream(FDecStream);
|
|
WriteDocIfEnabled(ASymbol);
|
|
if ASymbol.InheritsFrom(TPasTypeAliasType) then begin
|
|
typeModifier := 'type ';
|
|
end else begin
|
|
typeModifier := '';
|
|
end;
|
|
NewLine();
|
|
IncIndent();
|
|
Indent();
|
|
WriteLn('%s = %s%s;',[ASymbol.Name,typeModifier,ASymbol.DestType.Name]);
|
|
DecIndent();
|
|
except
|
|
on e : Exception do
|
|
GetLogger.Log(mtError,'TInftGenerator.GenerateTypeAlias()=',[ASymbol.Name, ' ;; ', e.Message]);
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateClass(ASymbol: TPasClassType);
|
|
var
|
|
locClassPropNbr, locOptionalPropsNbr, locArrayPropsNbr, locPropCount : Integer;
|
|
locPropList : TObjectList;
|
|
locParentIsEnum : Boolean;
|
|
|
|
procedure Prepare();
|
|
var
|
|
k : Integer;
|
|
elt : TPasElement;
|
|
p : TPasProperty;
|
|
begin
|
|
locPropCount := 0;
|
|
locClassPropNbr := 0;
|
|
locArrayPropsNbr := 0;
|
|
locOptionalPropsNbr := 0;
|
|
for k := 0 to Pred(ASymbol.Members.Count) do begin
|
|
elt := TPasElement(ASymbol.Members[k]);
|
|
if elt.InheritsFrom(TPasProperty) then begin
|
|
p := TPasProperty(elt);
|
|
locPropList.Add(p);
|
|
Inc(locPropCount);
|
|
if SymbolTable.IsOfType(p.VarType,TPasClassType) then
|
|
Inc(locClassPropNbr);
|
|
if SymbolTable.IsOfType(p.VarType,TPasArrayType) then
|
|
Inc(locArrayPropsNbr);
|
|
if AnsiSameText(sWST_PROP_STORE_PREFIX,Copy(p.StoredAccessorName,1,Length(sWST_PROP_STORE_PREFIX))) then
|
|
Inc(locOptionalPropsNbr);
|
|
end;
|
|
end;
|
|
locClassPropNbr := locClassPropNbr + locArrayPropsNbr;
|
|
end;
|
|
|
|
procedure WriteDec();
|
|
var
|
|
decBuffer, s : string;
|
|
elt : TPasElement;
|
|
ultimAnc, trueAncestor : TPasType;
|
|
begin
|
|
s := '';
|
|
if Assigned(ASymbol.AncestorType) then begin
|
|
trueAncestor := ASymbol.AncestorType;
|
|
if trueAncestor.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
elt := SymbolTable.FindElement(SymbolTable.GetExternalName(trueAncestor));
|
|
if (elt = nil) or (not elt.InheritsFrom(TPasType)) then
|
|
trueAncestor := nil
|
|
else
|
|
trueAncestor := TPasType(elt);
|
|
end;
|
|
if (trueAncestor <> nil) then begin
|
|
ultimAnc := GetUltimeType(trueAncestor);
|
|
if ultimAnc.InheritsFrom(TPasNativeSimpleType) then begin
|
|
trueAncestor := ultimAnc;
|
|
end;
|
|
if trueAncestor.InheritsFrom(TPasNativeSimpleType) and
|
|
Assigned(TPasNativeSimpleType(trueAncestor).ExtendableType)
|
|
then begin
|
|
trueAncestor := TPasNativeSimpleType(trueAncestor).ExtendableType;
|
|
end;
|
|
locParentIsEnum := trueAncestor.InheritsFrom(TPasEnumType);
|
|
if locParentIsEnum then
|
|
s := 'TComplexEnumContentRemotable'
|
|
else
|
|
s := Format('%s',[trueAncestor.Name]);
|
|
end;
|
|
end;
|
|
if IsStrEmpty(s) then begin
|
|
decBuffer := '';
|
|
end else begin
|
|
decBuffer := Format('(%s)',[s]);
|
|
end;
|
|
Indent();
|
|
WriteLn('%s = class%s',[ASymbol.Name,decBuffer]);
|
|
end;
|
|
|
|
function GetTypeText(AProp : TPasProperty; AActualPropType : TPasType) : string;
|
|
var
|
|
m : TPasModule;
|
|
begin
|
|
if AnsiSameText(AProp.Name,AActualPropType.Name) or
|
|
( SymbolTable.IsOfType(AActualPropType,TPasClassType) and Assigned(FindMember(TPasClassType(ASymbol),AActualPropType.Name)) )
|
|
then begin
|
|
m := FindModule(AActualPropType);
|
|
if (m = nil) then
|
|
m := SymbolTable.CurrentModule;
|
|
Result := Format('%s.%s',[m.Name,AActualPropType.Name]);
|
|
end else begin
|
|
Result := AActualPropType.Name;
|
|
end;
|
|
end;
|
|
|
|
procedure WriteProperty(AProp : TPasProperty; AActualPropType : TPasType);
|
|
var
|
|
propName, locStore : string;
|
|
begin
|
|
propName := AProp.Name;
|
|
if AnsiSameText('True',AProp.StoredAccessorName) then begin
|
|
locStore := '';
|
|
end else begin
|
|
locStore := Format(' stored %s',[AProp.StoredAccessorName]);
|
|
end;
|
|
Indent();
|
|
WriteLn('property %s : %s read F%s write F%s%s;',[propName,GetTypeText(AProp,AActualPropType),propName,propName,locStore]);
|
|
if not AnsiSameText(AProp.Name,SymbolTable.GetExternalName(AProp)) then begin
|
|
FImpLastStream.Indent();
|
|
FImpLastStream.WriteLn(
|
|
'%s.ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,QuotedStr(AProp.Name),QuotedStr(SymbolTable.GetExternalName(AProp))]
|
|
);
|
|
end;
|
|
if SymbolTable.IsAttributeProperty(AProp) then begin
|
|
FImpFirstStream.Indent();
|
|
FImpFirstStream.WriteLn('%s.RegisterAttributeProperty(%s);',[ASymbol.Name,QuotedStr(AProp.Name)]);
|
|
end;
|
|
end;
|
|
|
|
procedure WriteProperties();
|
|
var
|
|
k : Integer;
|
|
p : TPasProperty;
|
|
//e : TPasElement;
|
|
pt : TPasType;
|
|
begin
|
|
if ( locPropCount > 0 ) then begin
|
|
Indent();
|
|
WriteLn('private');
|
|
IncIndent();
|
|
for k := 0 to Pred(locPropCount) do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
pt := FindActualType(p.VarType,SymbolTable);
|
|
{if pt.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
e := SymbolTable.FindElement(SymbolTable.GetExternalName(pt));
|
|
if (e <> nil) and e.InheritsFrom(TPasType) then
|
|
pt := e as TPasType;
|
|
if (pt <> nil) and pt.InheritsFrom(TPasType) and (pt <> p.VarType) then begin
|
|
p.VarType.Release();
|
|
p.VarType := pt as TPasType;
|
|
p.VarType.AddRef();
|
|
end;
|
|
end;}
|
|
Indent();
|
|
WriteLn('F%s : %s;',[p.Name,GetTypeText(p,pt)]);
|
|
end;
|
|
if locParentIsEnum then begin
|
|
Indent();
|
|
WriteLn('FValue : %s;',[ASymbol.AncestorType.Name]);
|
|
end;
|
|
DecIndent();
|
|
//
|
|
if ( locOptionalPropsNbr > 0 ) then begin
|
|
Indent();
|
|
WriteLn('private');
|
|
IncIndent();
|
|
for k := 0 to Pred(locPropCount) do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
if AnsiSameText(sWST_PROP_STORE_PREFIX,Copy(p.StoredAccessorName,1,Length(sWST_PROP_STORE_PREFIX))) then begin
|
|
Indent();
|
|
WriteLn('function %s() : Boolean;',[p.StoredAccessorName]);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
end;
|
|
//
|
|
if locParentIsEnum then begin
|
|
Indent();
|
|
WriteLn('protected');
|
|
IncIndent();
|
|
Indent(); WriteLn('class function GetEnumTypeInfo() : PTypeInfo;override;');
|
|
Indent(); WriteLn('function GetValueAddress() : Pointer;override;');
|
|
DecIndent();
|
|
end;
|
|
//
|
|
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) or locParentIsEnum then begin
|
|
Indent();
|
|
WriteLn('public');
|
|
end;
|
|
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
|
|
IncIndent();
|
|
Indent(); WriteLn('constructor Create();override;');
|
|
Indent(); WriteLn('procedure FreeObjectProperties();override;');
|
|
DecIndent();
|
|
end;
|
|
if locParentIsEnum then begin
|
|
IncIndent();
|
|
Indent();
|
|
WriteLn('property Value : %s read FValue write FValue;',[ASymbol.AncestorType.Name]);
|
|
DecIndent();
|
|
end;
|
|
|
|
//
|
|
Indent();
|
|
WriteLn('published');
|
|
IncIndent();
|
|
For k := 0 To Pred(locPropCount) Do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
WriteProperty(p,FindActualType(p.VarType,SymbolTable));
|
|
end;
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
|
|
procedure WriteImp();
|
|
var
|
|
k : Integer;
|
|
p : TPasProperty;
|
|
pte : TPasElement;
|
|
pt : TPasType;
|
|
okCreation, okChoiceFields : Boolean;
|
|
begin
|
|
if ( locClassPropNbr > 0 ) then begin
|
|
NewLine();
|
|
WriteLn('{ %s }',[ASymbol.Name]);
|
|
|
|
if ( locClassPropNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
|
|
okChoiceFields := (goCreateChoiceFieldsInConstructor in Self.Options);
|
|
NewLine();
|
|
WriteLn('constructor %s.Create();',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent(); WriteLn('inherited Create();');
|
|
for k := 0 to Pred(locPropCount) do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
pt := FindActualType(p.VarType,SymbolTable);
|
|
okCreation := SymbolTable.IsOfType(pt,TPasArrayType);
|
|
if not okCreation then begin
|
|
okCreation := SymbolTable.IsOfType(pt,TPasClassType) and
|
|
(GetUltimeType(pt,SymbolTable) <> ASymbol) and
|
|
( not(SymbolTable.IsChoiceProperty(p)) or
|
|
okChoiceFields
|
|
);
|
|
end;
|
|
if okCreation then begin
|
|
Indent(); WriteLn('F%s := %s.Create();',[p.Name,GetTypeText(p,pt)]);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('procedure %s.FreeObjectProperties();',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
for k := 0 to Pred(locPropCount) do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
pt := FindActualType(p.VarType,SymbolTable);
|
|
if SymbolTable.IsOfType(pt,TPasClassType) or
|
|
SymbolTable.IsOfType(pt,TPasArrayType)
|
|
then begin
|
|
Indent(); WriteLn('if Assigned(F%s) then',[p.Name]);
|
|
IncIndent();
|
|
Indent(); WriteLn('FreeAndNil(F%s);',[p.Name]) ;
|
|
DecIndent();
|
|
end;
|
|
end;
|
|
Indent(); WriteLn('inherited FreeObjectProperties();');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
end;
|
|
for k := 0 to Pred(locPropCount) do begin
|
|
p := TPasProperty(locPropList[k]);
|
|
if AnsiSameText(sWST_PROP_STORE_PREFIX,Copy(p.StoredAccessorName,1,Length(sWST_PROP_STORE_PREFIX))) then begin
|
|
NewLine();
|
|
WriteLn('function %s.%s() : Boolean;',[ASymbol.Name,p.StoredAccessorName]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();
|
|
pte := FindActualType(p.VarType,SymbolTable);
|
|
if ( pte <> nil ) and pte.InheritsFrom(TPasType) then begin
|
|
pt := pte as TPasType;
|
|
pt := GetUltimeType(pt,SymbolTable);
|
|
if pt.InheritsFrom(TPasEnumType) then begin
|
|
WriteLn('Result := True;');
|
|
end else if pt.InheritsFrom(TPasNativeSimpleType) and
|
|
( AnsiPos('string', LowerCase(pt.Name)) > 0 )
|
|
then begin
|
|
WriteLn('Result := ( F%s <> '''' );',[p.Name]);
|
|
end else if pt.InheritsFrom(TPasNativeSimpleType) and
|
|
( AnsiSameText(pt.Name,'Single') or
|
|
AnsiSameText(pt.Name,'Double') or
|
|
AnsiSameText(pt.Name,'Extended') or
|
|
AnsiSameText(pt.Name,'Currency') or
|
|
AnsiSameText(pt.Name,'Real') or
|
|
AnsiSameText(pt.Name,'Comp')
|
|
)
|
|
then begin
|
|
WriteLn('Result := ( F%s <> 0 );',[p.Name]);
|
|
end else if pt.InheritsFrom(TPasClassType) then begin
|
|
WriteLn('Result := ( F%s <> nil );',[p.Name]);
|
|
end else begin
|
|
WriteLn('Result := ( F%s <> %s(0) );',[p.Name,p.VarType.Name]);
|
|
end;
|
|
end else begin
|
|
WriteLn('Result := ( F%s <> %s(0) );',[p.Name,p.VarType.Name]);
|
|
end;
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
end;
|
|
if locParentIsEnum then begin
|
|
NewLine();
|
|
WriteLn('class function %s.GetEnumTypeInfo() : PTypeInfo;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := TypeInfo(%s);',[ASymbol.AncestorType.Name]);
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
|
|
NewLine();
|
|
WriteLn('function %s.GetValueAddress() : Pointer;',[ASymbol.Name]);
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent();WriteLn('Result := @FValue;');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
end;
|
|
end;
|
|
|
|
var
|
|
strBuffer, locFormOptionString : string;
|
|
begin
|
|
locParentIsEnum := False;
|
|
locPropList := TObjectList.Create(False);
|
|
try
|
|
Prepare();
|
|
try
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
WriteDec();
|
|
WriteProperties();
|
|
Indent(); WriteLn('end;');
|
|
DecIndent();
|
|
|
|
if (FFormOptions <> '') then
|
|
locFormOptionString := Format(',%s',[FFormOptions])
|
|
else
|
|
locFormOptionString := '';
|
|
FImpTempStream.Indent();
|
|
strBuffer := Format(
|
|
'%s.Register(%s,TypeInfo(%s),%s%s);',
|
|
[ sLOCAL_TYPE_REGISTER_REFERENCE,sNAME_SPACE,ASymbol.Name,
|
|
QuotedStr(SymbolTable.GetExternalName(ASymbol)),
|
|
locFormOptionString
|
|
]
|
|
);
|
|
FImpTempStream.WriteLn(strBuffer);
|
|
|
|
SetCurrentStream(FImpStream);
|
|
WriteImp();
|
|
except
|
|
on e : Exception do begin
|
|
GetLogger.Log(mtError,'TInftGenerator.GenerateClass()=',[ASymbol.Name, ' ;; ', e.Message]);
|
|
raise;
|
|
end;
|
|
end;
|
|
finally
|
|
FreeAndNil(locPropList);
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateEnum(ASymbol: TPasEnumType);
|
|
var
|
|
itm : TPasEnumValue;
|
|
i : Integer;
|
|
begin
|
|
try
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
Indent();WriteLn('%s = ( ',[ASymbol.Name]);
|
|
|
|
FImpTempStream.Indent();
|
|
FImpTempStream.WriteLn(
|
|
'%s.Register(%s,TypeInfo(%s),%s);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,sNAME_SPACE,ASymbol.Name,QuotedStr(SymbolTable.GetExternalName(ASymbol))]
|
|
);
|
|
|
|
IncIndent();
|
|
for i := 0 to Pred(ASymbol.Values.Count) do begin
|
|
itm := TPasEnumValue(ASymbol.Values[i]);
|
|
Indent();
|
|
if ( i > 0 ) then
|
|
WriteLn(',%s',[itm.Name])
|
|
else
|
|
WriteLn('%s',[itm.Name]);
|
|
if SymbolTable.HasExternalName(itm) and
|
|
( not AnsiSameText(itm.Name,SymbolTable.GetExternalName(itm,False)) )
|
|
then begin
|
|
FImpTempStream.Indent();
|
|
FImpTempStream.WriteLn(
|
|
'%s.ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,QuotedStr(itm.Name),QuotedStr(SymbolTable.GetExternalName(itm,False))]
|
|
);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
Indent(); WriteLn(');');
|
|
DecIndent();
|
|
except
|
|
on e : Exception do
|
|
GetLogger.Log(mtError,'TInftGenerator.GenerateClass()=', [ASymbol.Name, ' ;; ', e.Message]);
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateArray(ASymbol: TPasArrayType);
|
|
var
|
|
classItemArray : Boolean;
|
|
eltType : TPasType;
|
|
begin
|
|
eltType := ASymbol.ElType;
|
|
if eltType.InheritsFrom(TPasUnresolvedTypeRef) then
|
|
eltType := FindActualType(eltType,SymbolTable);
|
|
classItemArray := SymbolTable.IsOfType(eltType,TPasClassType) or SymbolTable.IsOfType(eltType,TPasArrayType);
|
|
|
|
if classItemArray then begin
|
|
if ( goGenerateObjectCollection in Options ) or
|
|
SymbolTable.IsCollection(ASymbol)
|
|
then
|
|
WriteObjectCollection(ASymbol)
|
|
else
|
|
WriteObjectArray(ASymbol);
|
|
end else begin
|
|
WriteSimpleTypeArray(ASymbol);
|
|
end;
|
|
|
|
FImpTempStream.Indent();
|
|
FImpTempStream.WriteLn(
|
|
'%s.Register(%s,TypeInfo(%s),%s);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,sNAME_SPACE,ASymbol.Name,QuotedStr(SymbolTable.GetExternalName(ASymbol))]
|
|
);
|
|
if ( SymbolTable.GetArrayStyle(ASymbol) = asEmbeded ) then begin
|
|
FImpTempStream.Indent();
|
|
FImpTempStream.WriteLn(
|
|
'%s.ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(sARRAY_STYLE,sEmbedded);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,QuotedStr(SymbolTable.GetArrayItemExternalName(ASymbol))]
|
|
);
|
|
end else begin
|
|
if ( SymbolTable.GetArrayItemExternalName(ASymbol) <> sARRAY_ITEM_DEFAULT_EXTERNAL_NAME ) then begin
|
|
FImpTempStream.Indent();
|
|
FImpTempStream.WriteLn(
|
|
'%s.ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(sARRAY_ITEM,%s);',
|
|
[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,QuotedStr(SymbolTable.GetArrayItemExternalName(ASymbol))]
|
|
);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateRecord(ASymbol : TPasRecordType);
|
|
var
|
|
strFieldList : string;
|
|
|
|
procedure WriteDec();
|
|
var
|
|
itm : TPasVariable;
|
|
i : Integer;
|
|
begin
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
WriteDocIfEnabled(ASymbol);
|
|
IncIndent();
|
|
Indent(); WriteLn('%s = record',[ASymbol.Name]);
|
|
IncIndent();
|
|
strFieldList := '';
|
|
for i := 0 to Pred(ASymbol.Members.Count) do begin
|
|
itm := TPasVariable(ASymbol.Members[i]);
|
|
Indent();
|
|
WriteLn('%s : %s;',[itm.Name,itm.VarType.Name]);
|
|
if ( i > 0 ) then
|
|
strFieldList := Format('%s;%s',[strFieldList,itm.Name])
|
|
else
|
|
strFieldList := itm.Name;
|
|
end;
|
|
DecIndent();
|
|
Indent(); WriteLn('end;');
|
|
DecIndent();
|
|
end;
|
|
|
|
procedure WriteRTTI();
|
|
var
|
|
itm : TPasVariable;
|
|
k, c : Integer;
|
|
offsetLine, typeLine : string;
|
|
begin
|
|
SetCurrentStream(FRttiFunc);
|
|
NewLine();
|
|
WriteLn('{$IFDEF %s}',[sRECORD_RTTI_DEFINE]);
|
|
WriteLn('function __%s_TYPEINFO_FUNC__() : PTypeInfo;',[ASymbol.Name]);
|
|
WriteLn('var');
|
|
IncIndent();
|
|
Indent(); WriteLn('p : ^%s;',[ASymbol.Name]);
|
|
Indent(); WriteLn('r : %s;',[ASymbol.Name]);
|
|
DecIndent();
|
|
WriteLn('begin');
|
|
IncIndent();
|
|
Indent(); WriteLn('p := @r;');
|
|
Indent(); WriteLn('Result := MakeRawTypeInfo(');
|
|
IncIndent();
|
|
Indent(); WriteLn('%s,',[QuotedStr(ASymbol.Name)]);
|
|
Indent(); WriteLn('SizeOf(%s),',[ASymbol.Name]);
|
|
offsetLine := '[ ';
|
|
typeLine := '[ ';
|
|
c := ASymbol.Members.Count;
|
|
if ( c > 0 ) then begin
|
|
k := 1;
|
|
itm := TPasVariable(ASymbol.Members[(k-1)]);
|
|
offsetLine := offsetLine + Format('PtrUInt(@(p^.%s)) - PtrUInt(p)',[itm.Name]);
|
|
typeLine := typeLine + Format('TypeInfo(%s)',[itm.VarType.Name]);
|
|
Inc(k);
|
|
for k := k to c do begin
|
|
itm := TPasVariable(ASymbol.Members[(k-1)]);
|
|
offsetLine := offsetLine + Format(', PtrUInt(@(p^.%s)) - PtrUInt(p)',[itm.Name]);
|
|
typeLine := typeLine + Format(', TypeInfo(%s)',[itm.VarType.Name]);
|
|
end;
|
|
end;
|
|
offsetLine := offsetLine + ' ]';
|
|
typeLine := typeLine + ' ]';
|
|
Indent(); WriteLn('%s,',[offsetLine]);
|
|
Indent(); WriteLn('%s',[typeLine]);
|
|
DecIndent();
|
|
Indent(); WriteLn(');');
|
|
DecIndent();
|
|
WriteLn('end;');
|
|
WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]);
|
|
end;
|
|
|
|
procedure WriteAttributeProperties();
|
|
var
|
|
itm : TPasVariable;
|
|
k, c : Integer;
|
|
begin
|
|
c := ASymbol.Members.Count;
|
|
for k := 0 to Pred(c) do begin
|
|
itm := TPasVariable(ASymbol.Members[k]);
|
|
if SymbolTable.IsAttributeProperty(itm) then begin
|
|
FImpFirstStream.Indent();
|
|
FImpFirstStream.WriteLn('RegisterAttributeProperty(TypeInfo(%s),%s);',[ASymbol.Name,QuotedStr(itm.Name)]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
s : string;
|
|
begin
|
|
try
|
|
WriteDec();
|
|
WriteRTTI();
|
|
|
|
SetCurrentStream(FImpLastStream);
|
|
NewLine();
|
|
|
|
Indent();
|
|
WriteLn(
|
|
'%s.Register(%s,TypeInfo(%s),%s).RegisterExternalPropertyName(%s,%s);',
|
|
[ sLOCAL_TYPE_REGISTER_REFERENCE,sNAME_SPACE,ASymbol.Name,QuotedStr(SymbolTable.GetExternalName(ASymbol)),
|
|
QuotedStr(Format('__FIELDS__',[ASymbol.Name])),QuotedStr(strFieldList)
|
|
]
|
|
);
|
|
s := '%s.ItemByTypeInfo[TypeInfo(%s)]' +
|
|
'.RegisterObject(' +
|
|
'FIELDS_STRING,' +
|
|
'TRecordRttiDataObject.Create(' +
|
|
'MakeRecordTypeInfo(%s),' +
|
|
'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].GetExternalPropertyName(''__FIELDS__'')' +
|
|
')' +
|
|
');';
|
|
WriteLn('{$IFNDEF %s}',[sRECORD_RTTI_DEFINE]);
|
|
Indent(); WriteLn(s,[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,Format('TypeInfo(%s)',[ASymbol.Name]),ASymbol.Name]);
|
|
WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]);
|
|
|
|
WriteLn('{$IFDEF %s}',[sRECORD_RTTI_DEFINE]);
|
|
Indent(); WriteLn(s,[sLOCAL_TYPE_REGISTER_REFERENCE,ASymbol.Name,Format('__%s_TYPEINFO_FUNC__()',[ASymbol.Name]),ASymbol.Name]);
|
|
WriteLn('{$ENDIF %s}',[sRECORD_RTTI_DEFINE]);
|
|
WriteAttributeProperties();
|
|
SetCurrentStream(FDecStream);
|
|
except
|
|
on e : Exception do
|
|
GetLogger.Log(mtError,'TInftGenerator.GenerateRecord()=', [ASymbol.Name, ' ;; ', e.Message]);
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.GenerateCustomMetadatas();
|
|
|
|
procedure WriteOperationDatas(AInftDef : TPasClassType; AOp : TPasProcedure);
|
|
var
|
|
k : Integer;
|
|
pl : TStrings;
|
|
begin
|
|
pl := SymbolTable.Properties.FindList(AOp);
|
|
if ( pl <> nil ) then begin
|
|
for k := 0 to Pred(pl.Count) do begin
|
|
//if not IsStrEmpty(pl.ValueFromIndex[k]) then begin
|
|
Indent();WriteLn('mm.SetOperationCustomData(');
|
|
IncIndent();
|
|
Indent(); WriteLn('%s,',[sUNIT_NAME]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(AInftDef.Name)]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(AOp.Name)]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(pl.Names[k])]);
|
|
Indent(); WriteLn('%s' ,[QuotedStr(pl.ValueFromIndex[k])]);
|
|
DecIndent();
|
|
Indent();WriteLn(');');
|
|
//end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure WriteServiceDatas(ABinding : TwstBinding);
|
|
var
|
|
k : Integer;
|
|
opList : TList2;
|
|
elt : TPasElement;
|
|
begin
|
|
if not IsStrEmpty(ABinding.Address) then begin
|
|
Indent();WriteLn('mm.SetServiceCustomData(');
|
|
IncIndent();
|
|
Indent(); WriteLn('%s,',[sUNIT_NAME]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(ABinding.Intf.Name)]);
|
|
Indent(); WriteLn('%s,',[QuotedStr('TRANSPORT_Address')]);
|
|
Indent(); WriteLn('%s' ,[QuotedStr(ABinding.Address)]);
|
|
DecIndent();
|
|
Indent();WriteLn(');');
|
|
end;
|
|
|
|
if ( ABinding.BindingStyle = bsRPC ) then begin
|
|
Indent();WriteLn('mm.SetServiceCustomData(');
|
|
IncIndent();
|
|
Indent(); WriteLn('%s,',[sUNIT_NAME]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(ABinding.Intf.Name)]);
|
|
Indent(); WriteLn('%s,',[QuotedStr('FORMAT_Style')]);
|
|
Indent(); WriteLn('%s' ,[QuotedStr('rpc')]);
|
|
DecIndent();
|
|
Indent();WriteLn(');');
|
|
end else if ( ABinding.BindingStyle = bsDocument ) then begin
|
|
Indent();WriteLn('mm.SetServiceCustomData(');
|
|
IncIndent();
|
|
Indent(); WriteLn('%s,',[sUNIT_NAME]);
|
|
Indent(); WriteLn('%s,',[QuotedStr(ABinding.Intf.Name)]);
|
|
Indent(); WriteLn('%s,',[QuotedStr('FORMAT_Style')]);
|
|
Indent(); WriteLn('%s' ,[QuotedStr('document')]);
|
|
DecIndent();
|
|
Indent();WriteLn(');');
|
|
end;
|
|
|
|
opList := ABinding.Intf.Members;
|
|
for k := 0 to Pred(opList.Count) do begin
|
|
elt := TPasElement(opList[k]);
|
|
if elt.InheritsFrom(TPasProcedure) then begin
|
|
WriteOperationDatas(ABinding.Intf,TPasProcedure(elt));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i : Integer;
|
|
s : string;
|
|
begin
|
|
SetCurrentStream(FImpStream);
|
|
IncIndent();
|
|
|
|
NewLine();NewLine();
|
|
WriteLn('procedure Register_%s_ServiceMetadata();',[SymbolTable.CurrentModule.Name]);
|
|
WriteLn('var');
|
|
Indent(); WriteLn('mm : IModuleMetadataMngr;');
|
|
WriteLn('begin');
|
|
Indent();WriteLn('mm := GetModuleMetadataMngr();');
|
|
Indent();WriteLn('mm.SetRepositoryNameSpace(%s, %s);',[sUNIT_NAME,sNAME_SPACE]);
|
|
s := Trim(SymbolTable.Properties.GetValue(SymbolTable.CurrentModule,s_elementFormDefault));
|
|
if (s <> '') then begin
|
|
Indent();WriteLn('mm.SetRepositoryCustomData(%s, %s, %s);',[sUNIT_NAME,QuotedStr(s_elementFormDefault),QuotedStr(s)]);
|
|
end;
|
|
s := Trim(SymbolTable.Properties.GetValue(SymbolTable.CurrentModule,s_attributeFormDefault));
|
|
if (s <> '') then begin
|
|
Indent();WriteLn('mm.SetRepositoryCustomData(%s, %s, %s);',[sUNIT_NAME,QuotedStr(s_attributeFormDefault),QuotedStr(s)]);
|
|
end;
|
|
for i := 0 to Pred(SymbolTable.BindingCount) do begin
|
|
WriteServiceDatas(SymbolTable.Binding[i]);
|
|
end;
|
|
|
|
WriteLn('end;');
|
|
DecIndent();
|
|
end;
|
|
|
|
function TInftGenerator.GetDestUnitName(): string;
|
|
begin
|
|
Result := SymbolTable.CurrentModule.Name;
|
|
end;
|
|
|
|
procedure TInftGenerator.InternalExecute();
|
|
|
|
procedure SortRecords(AList : TList2);
|
|
var
|
|
j, k : Integer;
|
|
ordr_ls, mbrLs, locLs : TList2;
|
|
locMemberType : TPasType;
|
|
rec, locRec : TPasRecordType;
|
|
locStack : TStack;
|
|
locElt : TPasElement;
|
|
begin
|
|
if ( AList.Count > 0 ) then begin
|
|
locStack := nil;
|
|
locLs := nil;
|
|
ordr_ls := TList2.Create();
|
|
try
|
|
locStack := TStack.Create();
|
|
locLs := TList2.Create();
|
|
for j := 0 to Pred(AList.Count) do begin
|
|
rec := TPasRecordType(AList[j]);
|
|
if ( ordr_ls.IndexOf(rec) = -1 ) then begin
|
|
locStack.Push(rec);
|
|
while locStack.AtLeast(1) do begin
|
|
locLs.Clear();
|
|
locRec := TPasRecordType(locStack.Pop());
|
|
if ( ordr_ls.IndexOf(locRec) = -1 ) then begin
|
|
mbrLs := locRec.Members;
|
|
for k := 0 to Pred(mbrLs.Count) do begin
|
|
locMemberType := TPasVariable(mbrLs[k]).VarType;
|
|
if locMemberType.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
locElt := SymbolTable.FindElement(SymbolTable.GetExternalName(locMemberType));
|
|
if Assigned(locElt) and locElt.InheritsFrom(TPasType) then begin
|
|
locMemberType := locElt as TPasType;
|
|
end;
|
|
end;
|
|
if locMemberType.InheritsFrom(TPasRecordType) then begin
|
|
if ( ordr_ls.IndexOf(locMemberType) = -1 ) then
|
|
locLs.Add(locMemberType);
|
|
end;
|
|
end; //for
|
|
if ( locLs.Count > 0 ) then begin
|
|
locStack.Push(locRec);
|
|
for k := 0 to Pred(locLs.Count) do begin
|
|
locStack.Push(locLs[k]);
|
|
end;
|
|
end else begin
|
|
ordr_ls.Add(locRec);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Assert(not locStack.AtLeast(1));
|
|
AList.Clear();
|
|
for k := 0 to Pred(ordr_ls.Count) do begin
|
|
AList.Add(ordr_ls[k]);
|
|
end;
|
|
finally
|
|
FreeAndNil(locLs);
|
|
FreeAndNil(locStack);
|
|
FreeAndNil(ordr_ls);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure SortAlias(AList : TList2);
|
|
var
|
|
k, ki : Integer;
|
|
locElt : TPasElement;
|
|
locItem : TPasAliasType;
|
|
locTarget : TPasType;
|
|
begin
|
|
for k := 0 to Pred(AList.Count) do begin
|
|
locItem := TPasAliasType(AList[k]);
|
|
locTarget := locItem.DestType;
|
|
if (locTarget = nil) then
|
|
Continue;
|
|
if locTarget.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
locElt := SymbolTable.FindElement(SymbolTable.GetExternalName(locTarget));
|
|
if (locElt = nil) or not(locElt.InheritsFrom(TPasType)) then
|
|
Continue;
|
|
locTarget := locElt as TPasType;
|
|
end;
|
|
if not locTarget.InheritsFrom(TPasAliasType) then
|
|
Continue;
|
|
for ki := (k+1) to Pred(AList.Count) do begin
|
|
if (TPasType(AList[ki]) = locTarget) then begin
|
|
AList.Delete(ki);
|
|
AList.Insert(k,locTarget);
|
|
Break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
i, c, j, k : Integer;
|
|
clssTyp : TPasClassType;
|
|
gnrClssLst : TObjectList;
|
|
objLst : TObjectList;
|
|
typeList : TList2;
|
|
elt : TPasElement;
|
|
classAncestor : TPasElement;
|
|
tmpList : TList2;
|
|
intfCount : Integer;
|
|
locBinding : TwstBinding;
|
|
begin
|
|
intfCount := 0;
|
|
objLst := nil;
|
|
tmpList := nil;
|
|
gnrClssLst := TObjectList.Create(False);
|
|
try
|
|
typeList := SymbolTable.CurrentModule.InterfaceSection.Declarations;
|
|
c := Pred(typeList.Count);
|
|
GenerateUnitHeader(typeList.Count>0);
|
|
GenerateUnitImplementationHeader();
|
|
|
|
SetCurrentStream(FDecStream);
|
|
IncIndent();
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
WriteLn('// %s = unable to resolve this symbol.',[elt.Name]);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
|
|
IncIndent();
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasType) and
|
|
( not elt.InheritsFrom(TPasAliasType) ) and
|
|
( ( SymbolTable.IsOfType(TPasType(elt),TPasClassType) and ( TPasClassType(GetUltimeType(TPasType(elt))).ObjKind = okClass ) ) or
|
|
SymbolTable.IsOfType(TPasType(elt),TPasArrayType)
|
|
)
|
|
then begin
|
|
Indent();
|
|
WriteLn('%s = class;',[elt.Name]);
|
|
end;
|
|
end;
|
|
DecIndent();
|
|
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasEnumType) then begin
|
|
GenerateEnum(TPasEnumType(elt));
|
|
end;
|
|
end;
|
|
|
|
tmpList := TList2.Create();
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasRecordType) then begin
|
|
tmpList.Add(elt);
|
|
end;
|
|
end;
|
|
if ( tmpList.Count > 0 ) then begin
|
|
SortRecords(tmpList);
|
|
for i := 0 to Pred(tmpList.Count) do begin
|
|
GenerateRecord(TPasRecordType(tmpList[i]));
|
|
end;
|
|
tmpList.Clear();
|
|
end;
|
|
|
|
tmpList.Clear();
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasAliasType) then
|
|
tmpList.Add(elt);
|
|
end;
|
|
if (tmpList.Count > 0) then begin
|
|
SortAlias(tmpList);
|
|
for i := 0 to Pred(tmpList.Count) do
|
|
GenerateTypeAlias(TPasAliasType(tmpList[i]));
|
|
tmpList.Clear();
|
|
end;
|
|
|
|
objLst := TObjectList.Create();
|
|
objLst.OwnsObjects := False;
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasClassType) and ( TPasClassType(elt).ObjKind = okClass ) then begin
|
|
clssTyp := TPasClassType(elt);
|
|
if ( gnrClssLst.IndexOf(clssTyp) = -1 ) then begin
|
|
objLst.Clear();
|
|
while Assigned(clssTyp) and ( objLst.IndexOf(clssTyp) = -1 ) do begin
|
|
objLst.Add(clssTyp);
|
|
classAncestor := clssTyp.AncestorType;
|
|
if Assigned(classAncestor) and classAncestor.InheritsFrom(TPasUnresolvedTypeRef) then begin
|
|
classAncestor := SymbolTable.FindElement(SymbolTable.GetExternalName(classAncestor));
|
|
end;
|
|
if Assigned(classAncestor) and classAncestor.InheritsFrom(TPasClassType) then begin
|
|
clssTyp := classAncestor as TPasClassType;
|
|
end else begin
|
|
clssTyp := nil;
|
|
end;
|
|
end;
|
|
|
|
k := Pred(objLst.Count);
|
|
for j := 0 to k do begin
|
|
clssTyp := objLst[k-j] as TPasClassType;
|
|
if ( gnrClssLst.IndexOf(clssTyp) = -1 ) then begin
|
|
if ( SymbolTable.CurrentModule.InterfaceSection.Declarations.IndexOf(clssTyp) <> -1 ) then begin
|
|
GenerateClass(clssTyp);
|
|
gnrClssLst.Add(clssTyp);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasArrayType) then begin
|
|
GenerateArray(TPasArrayType(elt));
|
|
end;
|
|
end;
|
|
|
|
for i := 0 to c do begin
|
|
elt := TPasElement(typeList[i]);
|
|
if elt.InheritsFrom(TPasClassType) and ( TPasClassType(elt).ObjKind = okInterface ) then begin
|
|
GenerateIntf(TPasClassType(elt));
|
|
Inc(intfCount);
|
|
end;
|
|
end;
|
|
|
|
if ( goDocumentWrappedParameter in Self.Options ) then begin
|
|
c := SymbolTable.BindingCount;
|
|
if ( c > 0 ) then begin
|
|
for i := 0 to ( c - 1 ) do begin
|
|
locBinding := SymbolTable.Binding[i];
|
|
if (typeList.IndexOf(locBinding.Intf) >= 0) and
|
|
(locBinding.BindingStyle = bsDocument)
|
|
then begin
|
|
if (locBinding.EasyIntf = nil) then begin
|
|
locBinding.EasyIntf := DeduceEasyInterfaceForDocStyle(locBinding.Intf,SymbolTable);
|
|
if (locBinding.EasyIntf <> nil) then
|
|
locBinding.EasyIntf.Release();
|
|
end;
|
|
if ( locBinding.EasyIntf <> nil ) then
|
|
GenerateIntf(locBinding.EasyIntf);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
if ( intfCount > 0 ) then begin
|
|
SetCurrentStream(FDecStream);
|
|
NewLine();
|
|
IncIndent();
|
|
Indent(); WriteLn('procedure Register_%s_ServiceMetadata();',[SymbolTable.CurrentModule.Name]);
|
|
DecIndent();
|
|
GenerateCustomMetadatas();
|
|
end;
|
|
|
|
FImpFirstStream.NewLine();
|
|
FImpLastStream.NewLine();
|
|
GenerateUnitImplementationFooter();
|
|
SrcMngr.Merge(
|
|
GetDestUnitName() + '.pas',
|
|
[FDecStream,FImpStream,FRttiFunc,FImpFirstStream,FImpTempStream,FImpLastStream]
|
|
);
|
|
FDecStream := nil;
|
|
FImpStream := nil;
|
|
FImpTempStream := nil;
|
|
FRttiFunc := nil;
|
|
FImpLastStream := nil;
|
|
finally
|
|
FreeAndNil(tmpList);
|
|
FreeAndNil(objLst);
|
|
FreeAndNil(gnrClssLst);
|
|
end;
|
|
end;
|
|
|
|
procedure TInftGenerator.PrepareModule();
|
|
var
|
|
s : string;
|
|
begin
|
|
FDecStream := SrcMngr.CreateItem(GetDestUnitName() + '.dec');
|
|
FImpStream := SrcMngr.CreateItem(GetDestUnitName() + '.imp');
|
|
FImpTempStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp');
|
|
FImpFirstStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp_first');
|
|
FImpLastStream := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_imp_last');
|
|
FRttiFunc := SrcMngr.CreateItem(GetDestUnitName() + '.tmp_rtti_func');
|
|
FImpFirstStream.IncIndent();
|
|
FImpTempStream.IncIndent();
|
|
FImpLastStream.IncIndent();
|
|
|
|
FFormOptions := '';
|
|
s := SymbolTable.Properties.GetValue(SymbolTable.CurrentModule,s_elementFormDefault);
|
|
if (AnsiIndexStr(s,[s_unqualified,s_qualified]) >= 0) then
|
|
FFormOptions := Format('trio%sElement',[s]);
|
|
s := SymbolTable.Properties.GetValue(SymbolTable.CurrentModule,s_attributeFormDefault);
|
|
if (AnsiIndexStr(s,[s_unqualified,s_qualified]) >= 0) then begin
|
|
s := Format('trio%sAttribute',[s]);
|
|
if (FFormOptions <> '') then
|
|
FFormOptions := Format('%s, %s',[FFormOptions,s])
|
|
else
|
|
FFormOptions := s;
|
|
end;
|
|
if (FFormOptions <> '') then
|
|
FFormOptions := '[' + FFormOptions + ']';
|
|
end;
|
|
|
|
procedure TInftGenerator.Execute();
|
|
var
|
|
oldCurrent, mdl : TPasModule;
|
|
i : Integer;
|
|
mdlList : TList2;
|
|
oldCS : Boolean;
|
|
oldNamesKinds : TElementNameKinds;
|
|
begin
|
|
oldCS := SymbolTable.CaseSensitive;
|
|
oldNamesKinds := SymbolTable.DefaultSearchNameKinds;
|
|
oldCurrent := SymbolTable.CurrentModule;
|
|
try
|
|
SymbolTable.CaseSensitive := False;
|
|
SymbolTable.DefaultSearchNameKinds := [elkName];
|
|
mdlList := SymbolTable.Package.Modules;
|
|
for i := 0 to Pred(mdlList.Count) do begin
|
|
mdl := TPasModule(mdlList[i]);
|
|
if not mdl.InheritsFrom(TPasNativeModule) then begin
|
|
SymbolTable.SetCurrentModule(mdl);
|
|
PrepareModule();
|
|
InternalExecute();
|
|
end;
|
|
end;
|
|
finally
|
|
SymbolTable.SetCurrentModule(oldCurrent);
|
|
SymbolTable.CaseSensitive := oldCS;
|
|
SymbolTable.DefaultSearchNameKinds := oldNamesKinds;
|
|
end;
|
|
end;
|
|
|
|
end.
|