2006-08-26 00:35:42 +00:00
{
This unit is part of the Web Service Toolkit
Copyright ( c) 2 0 0 6 by Inoussa OUEDRAOGO
This program is free software; you can redistribute it and/ or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
( at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program ; if not , write to the Free Software
Foundation, Inc. , 6 7 5 Mass Ave, Cambridge, MA 0 2 1 3 9 , USA.
}
unit generator;
{$mode objfpc} {$H+}
interface
uses
Classes, SysUtils,
2007-06-24 23:33:51 +00:00
PasTree,
pascal_parser_intf, source_utils;
2006-08-26 00:35:42 +00:00
2006-11-12 13:31:22 +00:00
const
sWST_EXTENSION = 'wst' ;
type
2006-08-26 00:35:42 +00:00
{ TBaseGenerator }
TBaseGenerator = class
Private
FSrcMngr : ISourceManager;
FCurrentStream : ISourceStream;
2007-06-24 23:33:51 +00:00
FSymbolTable: TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
Protected
procedure SetCurrentStream( AStream : ISourceStream) ;
procedure Indent( ) ;
function IncIndent( ) : Integer ;
function DecIndent( ) : Integer ;
procedure BeginAutoIndent( ) ;
procedure EndAutoIndent( ) ;
procedure Write( AText : String ) ; overload ;
procedure Write( AText : String ; Const AArgs : array of const ) ; overload ;
procedure WriteLn( AText : String ) ; overload ;
procedure WriteLn( AText : String ; Const AArgs : array of const ) ; overload ;
procedure NewLine( ) ;
2007-06-24 23:33:51 +00:00
function ExtractserviceName( AIntf : TPasElement) : String ;
2006-08-26 00:35:42 +00:00
Public
constructor Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
ASrcMngr : ISourceManager
) ;
procedure Execute( ) ; virtual ; abstract ;
2007-06-24 23:33:51 +00:00
property SymbolTable : TwstPasTreeContainer Read FSymbolTable;
2006-08-26 00:35:42 +00:00
property SrcMngr : ISourceManager Read FSrcMngr;
End ;
{ TProxyGenerator }
TProxyGenerator = class( TBaseGenerator)
Private
FDecStream : ISourceStream;
2007-04-26 23:23:41 +00:00
FDecProcStream : ISourceStream;
2006-08-26 00:35:42 +00:00
FImpStream : ISourceStream;
2007-06-24 23:33:51 +00:00
function GenerateClassName( AIntf : TPasElement) : String ;
2006-08-26 00:35:42 +00:00
procedure GenerateUnitHeader( ) ;
procedure GenerateUnitImplementationHeader( ) ;
procedure GenerateUnitImplementationFooter( ) ;
2007-06-24 23:33:51 +00:00
procedure GenerateProxyIntf( AIntf : TPasClassType) ;
procedure GenerateProxyImp( AIntf : TPasClassType) ;
2006-08-26 00:35:42 +00:00
function GetDestUnitName( ) : string ;
Public
constructor Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
ASrcMngr : ISourceManager
) ;
procedure Execute( ) ; override ;
End ;
{ TStubGenerator }
TBinderGenerator = class( TBaseGenerator)
Private
FDecStream : ISourceStream;
FImpStream : ISourceStream;
2007-06-24 23:33:51 +00:00
function GenerateClassName( AIntf : TPasElement) : String ;
2006-08-26 00:35:42 +00:00
procedure GenerateUnitHeader( ) ;
procedure GenerateUnitImplementationHeader( ) ;
procedure GenerateUnitImplementationFooter( ) ;
2007-06-24 23:33:51 +00:00
procedure GenerateIntf( AIntf : TPasClassType) ;
procedure GenerateImp( AIntf : TPasClassType) ;
2006-08-26 00:35:42 +00:00
function GetDestUnitName( ) : string ;
Public
constructor Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
ASrcMngr : ISourceManager
) ;
procedure Execute( ) ; override ;
End ;
{ TImplementationGenerator }
TImplementationGenerator = class( TBaseGenerator)
Private
FDecStream : ISourceStream;
FImpStream : ISourceStream;
2007-06-24 23:33:51 +00:00
function GenerateClassName( AIntf : TPasElement) : String ;
2006-08-26 00:35:42 +00:00
procedure GenerateUnitHeader( ) ;
procedure GenerateUnitImplementationHeader( ) ;
procedure GenerateUnitImplementationFooter( ) ;
2007-06-24 23:33:51 +00:00
procedure GenerateIntf( AIntf : TPasClassType) ;
procedure GenerateImp( AIntf : TPasClassType) ;
2006-08-26 00:35:42 +00:00
function GetDestUnitName( ) : string ;
Public
constructor Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
ASrcMngr : ISourceManager
) ;
procedure Execute( ) ; override ;
End ;
2007-03-23 23:22:35 +00:00
{ TInftGenerator }
2006-08-26 00:35:42 +00:00
2007-03-23 23:22:35 +00:00
TInftGenerator = class( TBaseGenerator)
private
FDecStream : ISourceStream;
FImpStream : ISourceStream;
FImpTempStream : ISourceStream;
2007-04-17 00:52:02 +00:00
FImpLastStream : ISourceStream;
2007-03-23 23:22:35 +00:00
private
2007-06-24 23:33:51 +00:00
function GenerateIntfName( AIntf : TPasElement) : string ;
2007-03-23 23:22:35 +00:00
procedure GenerateUnitHeader( ) ;
procedure GenerateUnitImplementationHeader( ) ;
procedure GenerateUnitImplementationFooter( ) ;
2007-06-24 23:33:51 +00:00
procedure GenerateIntf( AIntf : TPasClassType) ;
procedure GenerateTypeAlias( ASymbol : TPasAliasType) ;
procedure GenerateClass( ASymbol : TPasClassType) ;
procedure GenerateEnum( ASymbol : TPasEnumType) ;
procedure GenerateArray( ASymbol : TPasArrayType) ;
2007-03-23 23:22:35 +00:00
2007-03-25 23:47:16 +00:00
procedure GenerateCustomMetadatas( ) ;
2007-03-23 23:22:35 +00:00
function GetDestUnitName( ) : string ;
public
constructor Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2007-03-23 23:22:35 +00:00
ASrcMngr : ISourceManager
) ;
procedure Execute( ) ; override ;
end ;
2006-08-26 00:35:42 +00:00
implementation
2007-06-24 23:33:51 +00:00
uses parserutils, Contnrs, logger_intf;
2006-08-26 00:35:42 +00:00
Const sPROXY_BASE_CLASS = 'TBaseProxy' ;
sBINDER_BASE_CLASS = 'TBaseServiceBinder' ;
sIMP_BASE_CLASS = 'TBaseServiceImplementation' ;
sSERIALIZER_CLASS = 'IFormatterClient' ;
2007-03-25 23:47:16 +00:00
//RETURN_PARAM_NAME = 'return';
2006-08-26 00:35:42 +00:00
RETURN_VAL_NAME = 'returnVal' ;
2007-03-23 23:22:35 +00:00
sNAME_SPACE = 'sNAME_SPACE' ;
2007-03-25 23:47:16 +00:00
sUNIT_NAME = 'sUNIT_NAME' ;
2006-08-26 00:35:42 +00:00
sPRM_NAME = 'strPrmName' ;
sLOC_SERIALIZER = 'locSerializer' ;
{ TProxyGenerator }
2007-06-24 23:33:51 +00:00
function TProxyGenerator. GenerateClassName( AIntf: TPasElement) : String ;
2006-08-26 00:35:42 +00:00
begin
Result : = ExtractserviceName( AIntf) ;
Result : = Format( 'T%s_Proxy' , [ Result ] ) ;
end ;
procedure TProxyGenerator. GenerateUnitHeader( ) ;
begin
SetCurrentStream( FDecStream) ;
WriteLn( '{' ) ;
WriteLn( 'This unit has been produced by ws_helper.' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' Input unit name : "%s".' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( ' This unit name : "%s".' , [ GetDestUnitName( ) ] ) ;
WriteLn( ' Date : "%s".' , [ DateTimeToStr( Now( ) ) ] ) ;
WriteLn( '}' ) ;
2007-05-05 19:05:01 +00:00
WriteLn( '' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'Unit %s;' , [ GetDestUnitName( ) ] ) ;
2007-05-05 19:05:01 +00:00
WriteLn( '{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'Interface' ) ;
WriteLn( '' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'Uses SysUtils, Classes, TypInfo, base_service_intf, service_intf, %s;' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( '' ) ;
WriteLn( 'Type' ) ;
WriteLn( '' ) ;
end ;
procedure TProxyGenerator. GenerateUnitImplementationHeader( ) ;
begin
SetCurrentStream( FImpStream) ;
WriteLn( '' ) ;
WriteLn( 'Implementation' ) ;
2006-11-12 13:31:22 +00:00
WriteLn( 'uses wst_resources_imp, metadata_repository;' ) ;
2006-08-26 00:35:42 +00:00
end ;
procedure TProxyGenerator. GenerateUnitImplementationFooter( ) ;
var
s : string ;
begin
SetCurrentStream( FImpStream) ;
NewLine( ) ;
WriteLn( 'initialization' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' {$i %s.%s}' , [ SymbolTable. CurrentModule. Name , sWST_EXTENSION] ) ;
2006-08-26 00:35:42 +00:00
NewLine( ) ;
2007-06-24 23:33:51 +00:00
s : = Format( 'Register_%s_ServiceMetadata' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( ' {$IF DECLARED(%s)}' , [ s] ) ;
WriteLn( ' %s();' , [ s] ) ;
2007-05-05 19:05:01 +00:00
WriteLn( ' {$IFEND}' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'End.' ) ;
end ;
constructor TProxyGenerator. Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2006-08-26 00:35:42 +00:00
ASrcMngr : ISourceManager
) ;
begin
Inherited Create( ASymTable, ASrcMngr) ;
FDecStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.dec' ) ;
2007-04-26 23:23:41 +00:00
FDecProcStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.dec_proc' ) ;
2006-08-26 00:35:42 +00:00
FImpStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.imp' ) ;
end ;
procedure TProxyGenerator. Execute( ) ;
Var
i, c : Integer ;
2007-06-24 23:33:51 +00:00
intf : TPasClassType;
elt : TPasElement;
ls : TList;
2006-08-26 00:35:42 +00:00
begin
GenerateUnitHeader( ) ;
GenerateUnitImplementationHeader( ) ;
2007-06-24 23:33:51 +00:00
ls : = SymbolTable. CurrentModule. InterfaceSection. Declarations;
c : = Pred( ls. Count) ;
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;
2006-08-26 00:35:42 +00:00
GenerateProxyIntf( intf) ;
GenerateProxyImp( intf) ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
GenerateUnitImplementationFooter( ) ;
2007-04-26 23:23:41 +00:00
FSrcMngr. Merge( GetDestUnitName( ) + '.pas' , [ FDecStream, FDecProcStream, FImpStream] ) ;
2007-06-24 23:33:51 +00:00
FDecStream : = nil ;
FImpStream : = nil ;
2006-08-26 00:35:42 +00:00
end ;
function TProxyGenerator. GetDestUnitName( ) : string ;
begin
2007-06-24 23:33:51 +00:00
Result : = Format( '%s_proxy' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure TProxyGenerator. GenerateProxyIntf( AIntf: TPasClassType) ;
2007-04-26 23:23:41 +00:00
2006-08-26 00:35:42 +00:00
procedure WriteDec( ) ;
begin
Indent( ) ;
WriteLn( '%s=class(%s,%s)' , [ GenerateClassName( AIntf) , sPROXY_BASE_CLASS, AIntf. Name ] ) ;
2007-04-26 23:23:41 +00:00
FDecProcStream. IncIndent( ) ;
try
FDecProcStream. NewLine( ) ;
FDecProcStream. Indent( ) ;
FDecProcStream. WriteLn( 'Function wst_CreateInstance_%s(const AFormat : string = %s; const ATransport : string = %s):%s;' , [ AIntf. Name , QuotedStr( 'SOAP:' ) , QuotedStr( 'HTTP:' ) , AIntf. Name ] ) ;
finally
FDecProcStream. DecIndent( ) ;
end ;
2006-08-26 00:35:42 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethod( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Var
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
prms : TList;
2006-08-26 00:35:42 +00:00
Begin
Indent( ) ;
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
if AMthd. InheritsFrom( TPasFunction) then begin
Write( 'function ' )
end else begin
2006-08-26 00:35:42 +00:00
Write( 'procedure ' )
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
Write( '%s(' , [ AMthd. Name ] ) ;
If ( prmCnt > 0 ) Then Begin
IncIndent( ) ;
For k : = 0 To Pred( prmCnt) Do Begin
2007-06-24 23:33:51 +00:00
prm : = TPasArgument( prms[ k] ) ;
2006-08-26 00:35:42 +00:00
If ( k > 0 ) Then
Write( '; ' ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
Write( '%s %s : %s' , [ AccessNames[ prm. Access] , prm. Name , prm. ArgType. Name ] ) ;
2006-08-26 00:35:42 +00:00
End ;
DecIndent( ) ;
NewLine( ) ;
Indent( ) ;
End ;
Write( ')' ) ;
2007-06-24 23:33:51 +00:00
if AMthd. InheritsFrom( TPasFunction) then begin
Write( ':%s' , [ TPasFunctionType( AMthd. ProcType) . ResultEl. ResultType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
WriteLn( ';' ) ;
End ;
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mthds : TList;
elt : TPasElement;
2006-08-26 00:35:42 +00:00
begin
2007-06-24 23:33:51 +00:00
if ( GetElementCount( AIntf. Members, TPasProcedure) = 0 ) then
2006-08-26 00:35:42 +00:00
Exit;
//IncIndent();
Indent( ) ;
WriteLn( 'Protected' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( 'class function GetServiceType() : PTypeInfo;override;' ) ;
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
//DecIndent();
end ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
WriteDec( ) ;
WriteMethods( ) ;
Indent( ) ; WriteLn( 'End;' ) ;
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TProxyGenerator. GenerateProxyImp( AIntf: TPasClassType) ;
2006-08-26 00:35:42 +00:00
Var
strClassName : String ;
procedure WriteDec( ) ;
begin
2007-04-26 23:23:41 +00:00
NewLine( ) ;
WriteLn( 'Function wst_CreateInstance_%s(const AFormat : string; const ATransport : string):%s;' , [ AIntf. Name , AIntf. Name ] ) ;
WriteLn( 'Begin' ) ;
IncIndent( ) ;
try
Indent( ) ;
WriteLn(
'Result := %s.Create(%s,AFormat+%s,ATransport + %s);' ,
[ strClassName, QuotedStr( AIntf. Name ) ,
Format( 'GetServiceDefaultFormatProperties(TypeInfo(%s))' , [ AIntf. Name ] ) ,
QuotedStr( 'address=' ) + Format( ' + GetServiceDefaultAddress(TypeInfo(%s))' , [ AIntf. Name ] )
]
) ;
finally
DecIndent( ) ;
end ;
WriteLn( 'End;' ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
if ( GetElementCount( AIntf. Members, TPasProcedure) > 0 ) then
2006-08-26 00:35:42 +00:00
WriteLn( '{ %s implementation }' , [ strClassName] ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethodDec( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Var
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
prms : TList;
2006-08-26 00:35:42 +00:00
Begin
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
if AMthd. InheritsFrom( TPasFunction) then begin
Write( 'function ' )
end else begin
Write( 'procedure ' ) ;
end ;
2006-08-26 00:35:42 +00:00
Write( '%s.%s(' , [ strClassName, AMthd. Name ] ) ;
If ( prmCnt > 0 ) Then Begin
IncIndent( ) ;
For k : = 0 To Pred( prmCnt) Do Begin
2007-06-24 23:33:51 +00:00
prm : = TPasArgument( prms[ k] ) ;
2006-08-26 00:35:42 +00:00
If ( k > 0 ) Then
Write( '; ' ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
Write( '%s %s : %s' , [ AccessNames[ prm. Access] , prm. Name , prm. ArgType. Name ] ) ;
2006-08-26 00:35:42 +00:00
End ;
DecIndent( ) ;
NewLine( ) ;
Indent( ) ;
End ;
Write( ')' ) ;
2007-06-24 23:33:51 +00:00
if AMthd. InheritsFrom( TPasFunction) then begin
Write( ':%s' , [ TPasFunctionType( AMthd. ProcType) . ResultEl. ResultType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
WriteLn( ';' ) ;
End ;
2007-06-24 23:33:51 +00:00
procedure WriteMethodImp( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Var
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
resPrm : TPasResultElement;
prms : TList;
2006-08-26 00:35:42 +00:00
Begin
IncIndent( ) ;
WriteLn( 'Var' ) ;
Indent( ) ; WriteLn( '%s : %s;' , [ sLOC_SERIALIZER, sSERIALIZER_CLASS] ) ;
Indent( ) ; WriteLn( '%s : %s;' , [ sPRM_NAME, 'string' ] ) ;
2007-04-02 13:19:48 +00:00
2006-08-26 00:35:42 +00:00
WriteLn( 'Begin' ) ;
Indent( ) ; WriteLn( '%s := GetSerializer();' , [ sLOC_SERIALIZER] ) ;
Indent( ) ; WriteLn( 'Try' ) ; IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s.BeginCall(' '%s' ', GetTarget(),(Self as ICallContext));' , [ sLOC_SERIALIZER, SymbolTable. GetExternalName( AMthd) ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
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 ] ) ;
2006-08-26 00:35:42 +00:00
End ;
End ;
DecIndent( ) ;
Indent( ) ; WriteLn( '%s.EndCall();' , [ sLOC_SERIALIZER] ) ;
WriteLn( '' ) ;
Indent( ) ; WriteLn( 'MakeCall();' ) ;
WriteLn( '' ) ;
Indent( ) ; WriteLn( '%s.BeginCallRead((Self as ICallContext));' , [ sLOC_SERIALIZER] ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
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)
2007-03-23 23:22:35 +00:00
then begin
Indent( ) ; WriteLn( 'TObject(Result) := Nil;' ) ;
2006-08-26 00:35:42 +00:00
end else begin
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'If ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) Then' , [ resPrm. ResultType. Name ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
Indent( ) ; WriteLn( 'Pointer(Result) := Nil;' ) ;
DecIndent( ) ;
end ;
end ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s := %s;' , [ sPRM_NAME, QuotedStr( FSymbolTable. GetExternalName( resPrm) ) ] ) ;
Indent( ) ; WriteLn( '%s.Get(TypeInfo(%s), %s, %s);' , [ sLOC_SERIALIZER, resPrm. ResultType. Name , sPRM_NAME, 'Result' ] ) ;
end ;
2006-08-26 00:35:42 +00:00
//--------------------------------
for k : = 0 to Pred( prmCnt) do begin
2007-06-24 23:33:51 +00:00
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)
2007-03-23 23:22:35 +00:00
then begin
Indent( ) ; WriteLn( 'TObject(%s) := Nil;' , [ prm. Name ] ) ;
end else begin
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'If ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) Then' , [ prm. ArgType. Name ] ) ;
2007-03-23 23:22:35 +00:00
IncIndent( ) ;
Indent( ) ; WriteLn( 'Pointer(%s) := Nil;' , [ prm. Name ] ) ;
DecIndent( ) ;
end ;
2006-08-26 00:35:42 +00:00
end ;
end ;
end ;
//--------------------------------
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
WriteLn( '' ) ;
DecIndent( ) ;
Indent( ) ; WriteLn( 'Finally' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( '%s.Clear();' , [ sLOC_SERIALIZER] ) ;
DecIndent( ) ;
Indent( ) ; WriteLn( 'End;' ) ; DecIndent( ) ;
WriteLn( 'End;' ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
procedure WriteTypeInfoMethod( ) ;
begin
NewLine( ) ;
WriteLn( 'class function %s.GetServiceType() : PTypeInfo;' , [ strClassName] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( 'result := TypeInfo(%s);' , [ AIntf. Name ] ) ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
NewLine( ) ;
end ;
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mthds : TList;
elt : TPasElement;
2006-08-26 00:35:42 +00:00
begin
WriteTypeInfoMethod( ) ;
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
end ;
begin
SetCurrentStream( FImpStream) ;
IncIndent( ) ;
While ( DecIndent( ) > 0 ) Do
;
strClassName : = GenerateClassName( AIntf) ;
NewLine( ) ;
WriteDec( ) ;
WriteMethods( ) ;
end ;
{ TBaseGenerator }
procedure TBaseGenerator. SetCurrentStream( AStream: ISourceStream) ;
begin
FCurrentStream : = AStream;
end ;
procedure TBaseGenerator. Indent( ) ;
begin
FCurrentStream. Indent( ) ;
end ;
function TBaseGenerator. IncIndent( ) : Integer ;
begin
Result : = FCurrentStream. IncIndent( ) ;
end ;
function TBaseGenerator. DecIndent( ) : Integer ;
begin
Result : = FCurrentStream. DecIndent( ) ;
end ;
procedure TBaseGenerator. BeginAutoIndent( ) ;
begin
FCurrentStream. BeginAutoIndent( ) ;
end ;
procedure TBaseGenerator. EndAutoIndent( ) ;
begin
FCurrentStream. EndAutoIndent( ) ;
end ;
procedure TBaseGenerator. Write( AText: String ) ;
begin
FCurrentStream. Write( AText) ;
end ;
procedure TBaseGenerator. Write( AText: String ; const AArgs: array of const ) ;
begin
Write( Format( AText, AArgs) ) ;
end ;
procedure TBaseGenerator. WriteLn( AText: String ) ;
begin
Write( AText+ sNEW_LINE) ;
end ;
procedure TBaseGenerator. WriteLn( AText: String ; const AArgs: array of const ) ;
begin
Write( AText+ sNEW_LINE, AArgs) ;
end ;
procedure TBaseGenerator. NewLine( ) ;
begin
WriteLn( '' ) ;
end ;
2007-06-24 23:33:51 +00:00
function TBaseGenerator. ExtractserviceName( AIntf: TPasElement) : String ;
2006-08-26 00:35:42 +00:00
begin
Result : = AIntf. Name ;
If upCase( Result [ 1 ] ) = 'I' Then
Delete( Result , 1 , 1 ) ;
end ;
2007-06-24 23:33:51 +00:00
constructor TBaseGenerator. Create( ASymTable: TwstPasTreeContainer; ASrcMngr: ISourceManager) ;
2006-08-26 00:35:42 +00:00
begin
Assert( Assigned( ASymTable) ) ;
Assert( Assigned( ASrcMngr) ) ;
FSrcMngr : = ASrcMngr;
FCurrentStream : = Nil ;
FSymbolTable : = ASymTable;
end ;
{ TBinderGenerator }
2007-06-24 23:33:51 +00:00
function TBinderGenerator. GenerateClassName( AIntf: TPasElement) : String ;
2006-08-26 00:35:42 +00:00
begin
Result : = ExtractserviceName( AIntf) ;
Result : = Format( 'T%s_ServiceBinder' , [ Result ] ) ;
end ;
procedure TBinderGenerator. GenerateUnitHeader( ) ;
begin
SetCurrentStream( FDecStream) ;
WriteLn( '{' ) ;
WriteLn( 'This unit has been produced by ws_helper.' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' Input unit name : "%s".' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( ' This unit name : "%s".' , [ GetDestUnitName( ) ] ) ;
WriteLn( ' Date : "%s".' , [ DateTimeToStr( Now( ) ) ] ) ;
WriteLn( '}' ) ;
WriteLn( 'unit %s;' , [ GetDestUnitName( ) ] ) ;
2007-05-05 19:05:01 +00:00
WriteLn( '{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'interface' ) ;
WriteLn( '' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'uses SysUtils, Classes, base_service_intf, server_service_intf, %s;' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( '' ) ;
WriteLn( 'type' ) ;
WriteLn( '' ) ;
end ;
procedure TBinderGenerator. GenerateUnitImplementationHeader( ) ;
begin
SetCurrentStream( FImpStream) ;
WriteLn( '' ) ;
WriteLn( 'Implementation' ) ;
2006-11-12 13:31:22 +00:00
WriteLn( 'uses TypInfo, wst_resources_imp,metadata_repository;' ) ;
2006-08-26 00:35:42 +00:00
end ;
procedure TBinderGenerator. GenerateUnitImplementationFooter( ) ;
var
s : string ;
begin
NewLine( ) ;
WriteLn( 'initialization' ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
s : = Format( 'Register_%s_NameSpace' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( ' {$IF DECLARED(%s)}' , [ s] ) ;
WriteLn( ' %s();' , [ s] ) ;
WriteLn( ' {$ENDIF}' ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' {$i %s.%s}' , [ SymbolTable. CurrentModule. Name , sWST_EXTENSION] ) ;
2006-08-26 00:35:42 +00:00
NewLine( ) ;
WriteLn( 'End.' ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TBinderGenerator. GenerateIntf( AIntf: TPasClassType) ;
2006-08-26 00:35:42 +00:00
procedure WriteDec( ) ;
begin
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( '%s = class(%s)' , [ GenerateClassName( AIntf) , sBINDER_BASE_CLASS] ) ;
2006-08-26 00:35:42 +00:00
end ;
procedure WriteConstructor( ) ;
Begin
Indent( ) ;
WriteLn( 'constructor Create();' )
End ;
2007-06-24 23:33:51 +00:00
procedure WriteMethod( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Begin
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'procedure %sHandler(AFormatter : IFormatterResponse; AContext : ICallContext);' , [ AMthd. Name ] )
2006-08-26 00:35:42 +00:00
End ;
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mbrs : TList;
elt : TPasElement;
2006-08-26 00:35:42 +00:00
begin
2007-06-24 23:33:51 +00:00
if ( GetElementCount( AIntf. Members, TPasProcedure) > 0 ) then begin
Indent( ) ; WriteLn( 'protected' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'public' ) ;
2006-08-26 00:35:42 +00:00
Indent( ) ; WriteConstructor( ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
end ;
procedure GenerateFactoryClass( ) ;
Begin
NewLine( ) ;
IncIndent( ) ; BeginAutoIndent( ) ;
WriteLn( 'T%s_ServiceBinderFactory = class(TInterfacedObject,IItemFactory)' , [ ExtractserviceName( AIntf) ] ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'private' ) ;
IncIndent( ) ;
WriteLn( 'FInstance : IInterface;' ) ;
DecIndent( ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'protected' ) ;
IncIndent( ) ;
WriteLn( 'function CreateInstance():IInterface;' ) ;
DecIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'public' ) ;
IncIndent( ) ;
WriteLn( 'constructor Create();' ) ;
WriteLn( 'destructor Destroy();override;' ) ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ; EndAutoIndent( ) ;
End ;
2007-06-24 23:33:51 +00:00
2006-08-26 00:35:42 +00:00
procedure GenerateRegistrationProc( ) ;
Begin
NewLine( ) ;
BeginAutoIndent( ) ;
IncIndent( ) ;
WriteLn( 'procedure Server_service_Register%sService();' , [ ExtractserviceName( AIntf) ] ) ;
DecIndent( ) ;
EndAutoIndent( ) ;
End ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
WriteDec( ) ;
WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'end;' ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
GenerateFactoryClass( ) ;
GenerateRegistrationProc( ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TBinderGenerator. GenerateImp( AIntf: TPasClassType) ;
2006-08-26 00:35:42 +00:00
Var
strClassName : String ;
procedure WriteDec( ) ;
begin
2007-06-24 23:33:51 +00:00
if ( GetElementCount( AIntf. Members, TPasProcedure) > 0 ) then
2006-08-26 00:35:42 +00:00
WriteLn( '{ %s implementation }' , [ strClassName] ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethodDec( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Begin
2007-06-24 23:33:51 +00:00
WriteLn( 'procedure %s.%sHandler(AFormatter : IFormatterResponse; AContext : ICallContext);' , [ strClassName, AMthd. Name ] ) ;
2006-08-26 00:35:42 +00:00
End ;
2007-06-24 23:33:51 +00:00
procedure WriteMethodImp( AMthd : TPasProcedure) ;
2006-08-26 00:35:42 +00:00
Var
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
prms : TList;
resElt : TPasResultElement;
2006-08-26 00:35:42 +00:00
strBuff : string ;
Begin
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
WriteLn( 'var' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ; BeginAutoIndent( ) ;
WriteLn( 'cllCntrl : ICallControl;' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'objCntrl : IObjectControl;' ) ;
WriteLn( 'hasObjCntrl : Boolean;' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'tmpObj : %s;' , [ AIntf. Name ] ) ;
WriteLn( 'callCtx : ICallContext;' ) ;
2007-06-24 23:33:51 +00:00
if ( prmCnt > 0 ) or AMthd. InheritsFrom( TPasFunction) then begin
2006-08-26 00:35:42 +00:00
WriteLn( '%s : string;' , [ sPRM_NAME] ) ;
WriteLn( 'procName,trgName : string;' ) ;
2007-06-24 23:33:51 +00:00
end ;
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 ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ; EndAutoIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'begin' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ; BeginAutoIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'callCtx := AContext;' ) ;
if AMthd. InheritsFrom( TPasFunction) then begin
resElt : = TPasFunctionType( AMthd. ProcType) . ResultEl;
if SymbolTable. IsInitNeed( resElt. ResultType) then begin
if ( SymbolTable. IsOfType( resElt. ResultType, TPasClassType) and
( TPasClassType( GetUltimeType( resElt. ResultType) ) . ObjKind = okClass )
) or
SymbolTable. IsOfType( resElt. ResultType, TPasArrayType)
then begin
WriteLn( 'TObject(%s) := nil;' , [ RETURN_VAL_NAME] ) ;
2006-08-26 00:35:42 +00:00
end else begin
2007-06-24 23:33:51 +00:00
WriteLn( 'if ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkInterface] ) then' , [ resElt. ResultType. Name ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'Pointer(%s) := nil;' , [ RETURN_VAL_NAME] ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( prmCnt) do begin
prm : = TPasArgument( prms[ k] ) ;
if SymbolTable. IsInitNeed( prm. ArgType) then begin
if SymbolTable. IsOfType( prm. ArgType, TPasClassType) or
SymbolTable. IsOfType( prm. ArgType, TPasArrayType)
then begin
WriteLn( 'TObject(%s) := nil;' , [ prm. Name ] ) ;
2006-08-26 00:35:42 +00:00
end else begin
2007-06-24 23:33:51 +00:00
WriteLn( 'if ( PTypeInfo(TypeInfo(%s))^.Kind in [tkClass,tkObject,tkInterface] ) then' , [ prm. ArgType. Name ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'Pointer(%s) := nil;' , [ prm. Name ] ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
NewLine( ) ;
2007-06-24 23:33:51 +00:00
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 Assigned(Pointer(%s)) then' , [ prm. Name ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
WriteLn( 'callCtx.AddObjectToFree(TObject(%s));' , [ prm. Name ] ) ;
DecIndent( ) ;
end else begin
2007-06-24 23:33:51 +00:00
WriteLn( 'if ( PTypeInfo(TypeInfo(%s))^.Kind = tkClass ) and Assigned(Pointer(%s)) then' , [ prm. ArgType. Name , prm. Name ] ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
WriteLn( 'callCtx.AddObjectToFree(TObject(%s));' , [ prm. Name ] ) ;
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
NewLine( ) ;
WriteLn( 'tmpObj := Self.GetFactory().CreateInstance() as %s;' , [ AIntf. Name ] ) ;
WriteLn( 'if Supports(tmpObj,ICallControl,cllCntrl) then' ) ;
2007-06-24 23:33:51 +00:00
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
if SymbolTable. IsOfType( resElt. ResultType, TPasClassType) or SymbolTable. IsOfType( resElt. ResultType, TPasArrayType) then
WriteLn( 'if Assigned(TObject(%s)) then' , [ RETURN_VAL_NAME] )
else
WriteLn( 'if ( PTypeInfo(TypeInfo(%s))^.Kind = tkClass ) and Assigned(Pointer(%s)) then' , [ resElt. ResultType. Name , RETURN_VAL_NAME] ) ;
IncIndent( ) ;
WriteLn( 'callCtx.AddObjectToFree(TObject(%s));' , [ RETURN_VAL_NAME] ) ;
DecIndent( ) ;
end ;
end ;
NewLine( ) ;
2006-08-26 00:35:42 +00:00
2007-06-24 23:33:51 +00:00
WriteLn( 'procName := AFormatter.GetCallProcedureName();' ) ;
WriteLn( 'trgName := AFormatter.GetCallTarget();' ) ;
WriteLn( 'AFormatter.Clear();' ) ;
WriteLn( 'AFormatter.BeginCallResponse(procName,trgName);' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'AFormatter.EndCallResponse();' ) ;
NewLine( ) ;
WriteLn( 'callCtx := nil;' ) ;
2006-08-26 00:35:42 +00:00
2007-06-24 23:33:51 +00:00
DecIndent( ) ;
WriteLn( 'finally' ) ;
WriteLn( ' if hasObjCntrl then' ) ;
WriteLn( ' objCntrl.Deactivate();' ) ;
WriteLn( ' Self.GetFactory().ReleaseInstance(tmpObj);' ) ;
WriteLn( 'end;' ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ; EndAutoIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'end;' ) ;
2006-08-26 00:35:42 +00:00
End ;
procedure WriteConstructor( ) ;
Var
k : Integer ;
2007-06-24 23:33:51 +00:00
mtd : TPasProcedure;
mtds : TList;
2006-08-26 00:35:42 +00:00
Begin
NewLine( ) ;
WriteLn( 'constructor %s.Create();' , [ strClassName] ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'begin' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
BeginAutoIndent( ) ;
2007-06-24 23:33:51 +00:00
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,@%sHandler);' , [ QuotedStr( mtd. Name ) , mtd. Name ] ) ;
end ;
end ;
2006-08-26 00:35:42 +00:00
EndAutoIndent( ) ;
DecIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'end;' ) ;
2006-08-26 00:35:42 +00:00
NewLine( ) ;
End ;
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mtds : TList;
mtd : TPasProcedure;
2006-08-26 00:35:42 +00:00
begin
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
WriteConstructor( ) ;
end ;
procedure GenerateFactoryClass( ) ;
Var
strBuff : string ;
Begin
NewLine( ) ;
BeginAutoIndent( ) ;
strBuff : = Format( 'T%s_ServiceBinderFactory' , [ ExtractserviceName( AIntf) ] ) ;
WriteLn( '{ %s }' , [ strBuff] ) ;
2007-06-24 23:33:51 +00:00
NewLine( ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'function %s.CreateInstance():IInterface;' , [ strBuff] ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'begin' ) ;
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'Result := FInstance;' , [ strClassName] ) ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
2007-06-24 23:33:51 +00:00
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;' ) ;
2006-08-26 00:35:42 +00:00
EndAutoIndent( ) ;
End ;
2007-06-24 23:33:51 +00:00
2006-08-26 00:35:42 +00:00
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( AIntf. Name ) , strBuff] ) ;
DecIndent( ) ;
WriteLn( 'End;' ) ;
EndAutoIndent( ) ;
End ;
begin
SetCurrentStream( FImpStream) ;
IncIndent( ) ;
While ( DecIndent( ) > 0 ) Do
;
strClassName : = GenerateClassName( AIntf) ;
NewLine( ) ;
WriteDec( ) ;
WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
2006-08-26 00:35:42 +00:00
GenerateFactoryClass( ) ;
GenerateRegistrationProc( ) ;
end ;
function TBinderGenerator. GetDestUnitName( ) : string ;
begin
2007-06-24 23:33:51 +00:00
Result : = Format( '%s_binder' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
end ;
2007-06-24 23:33:51 +00:00
constructor TBinderGenerator. Create( ASymTable: TwstPasTreeContainer; ASrcMngr: ISourceManager) ;
2006-08-26 00:35:42 +00:00
begin
Inherited Create( ASymTable, ASrcMngr) ;
FDecStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.dec' ) ;
FImpStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.imp' ) ;
end ;
procedure TBinderGenerator. Execute( ) ;
Var
i, c : Integer ;
2007-06-24 23:33:51 +00:00
intf : TPasClassType;
typeList : TList;
elt : TPasElement;
2006-08-26 00:35:42 +00:00
begin
GenerateUnitHeader( ) ;
GenerateUnitImplementationHeader( ) ;
2007-07-12 14:46:45 +00:00
typeList : = SymbolTable. CurrentModule. InterfaceSection. Declarations;
2007-06-24 23:33:51 +00:00
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) ;
2006-08-26 00:35:42 +00:00
GenerateIntf( intf) ;
GenerateImp( intf) ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
GenerateUnitImplementationFooter( ) ;
FSrcMngr. Merge( GetDestUnitName( ) + '.pas' , [ FDecStream, FImpStream] ) ;
2007-06-24 23:33:51 +00:00
FDecStream : = nil ;
FImpStream : = nil ;
2006-08-26 00:35:42 +00:00
end ;
{ TImplementationGenerator }
2007-06-24 23:33:51 +00:00
function TImplementationGenerator. GenerateClassName( AIntf: TPasElement) : String ;
2006-08-26 00:35:42 +00:00
begin
Result : = ExtractserviceName( AIntf) ;
Result : = Format( 'T%s_ServiceImp' , [ Result ] ) ;
end ;
procedure TImplementationGenerator. GenerateUnitHeader( ) ;
begin
SetCurrentStream( FDecStream) ;
WriteLn( '{' ) ;
WriteLn( 'This unit has been produced by ws_helper.' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' Input unit name : "%s".' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( ' This unit name : "%s".' , [ GetDestUnitName( ) ] ) ;
WriteLn( ' Date : "%s".' , [ DateTimeToStr( Now( ) ) ] ) ;
WriteLn( '}' ) ;
WriteLn( 'Unit %s;' , [ GetDestUnitName( ) ] ) ;
2007-05-05 19:05:01 +00:00
WriteLn( '{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}' ) ;
2006-08-26 00:35:42 +00:00
WriteLn( 'Interface' ) ;
WriteLn( '' ) ;
WriteLn( 'Uses SysUtils, Classes, ' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' base_service_intf, server_service_intf, server_service_imputils, %s;' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
WriteLn( '' ) ;
WriteLn( 'Type' ) ;
WriteLn( '' ) ;
end ;
procedure TImplementationGenerator. GenerateUnitImplementationHeader( ) ;
begin
SetCurrentStream( FImpStream) ;
WriteLn( '' ) ;
WriteLn( 'Implementation' ) ;
end ;
procedure TImplementationGenerator. GenerateUnitImplementationFooter( ) ;
begin
NewLine( ) ;
WriteLn( 'End.' ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TImplementationGenerator. GenerateIntf( AIntf: TPasClassType) ;
2006-08-26 00:35:42 +00:00
procedure WriteDec( ) ;
begin
Indent( ) ;
WriteLn( '%s=class(%s,%s)' , [ GenerateClassName( AIntf) , sIMP_BASE_CLASS, AIntf. Name ] ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethod( AMthd : TPasProcedure) ;
var
2006-08-26 00:35:42 +00:00
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
prms : TList;
begin
2006-08-26 00:35:42 +00:00
Indent( ) ;
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
if AMthd. InheritsFrom( TPasFunction) then begin
Write( 'function ' )
end else begin
Write( 'procedure ' ) ;
end ;
2006-08-26 00:35:42 +00:00
Write( '%s(' , [ AMthd. Name ] ) ;
2007-06-24 23:33:51 +00:00
if ( prmCnt > 0 ) then begin
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( prmCnt) do begin
prm : = TPasArgument( prms[ k] ) ;
if ( k > 0 ) then
2006-08-26 00:35:42 +00:00
Write( '; ' ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
Write( '%s %s : %s' , [ AccessNames[ prm. Access] , prm. Name , prm. ArgType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
Write( ')' ) ;
2007-06-24 23:33:51 +00:00
if AMthd. InheritsFrom( TPasFunction) then begin
Write( ':%s' , [ TPasFunctionType( AMthd. ProcType) . ResultEl. ResultType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
WriteLn( ';' ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mtds : TList;
elt : TPasElement;
2006-08-26 00:35:42 +00:00
begin
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
end ;
procedure GenerateRegistrationProc( ) ;
Begin
NewLine( ) ;
BeginAutoIndent( ) ;
IncIndent( ) ;
WriteLn( 'procedure Register%sImplementationFactory();' , [ ExtractserviceName( AIntf) ] ) ;
DecIndent( ) ;
EndAutoIndent( ) ;
End ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
WriteDec( ) ;
WriteMethods( ) ;
Indent( ) ; WriteLn( 'End;' ) ;
NewLine( ) ;
DecIndent( ) ;
GenerateRegistrationProc( ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TImplementationGenerator. GenerateImp( AIntf: TPasClassType) ;
var
2006-08-26 00:35:42 +00:00
strClassName : String ;
procedure WriteDec( ) ;
begin
2007-06-24 23:33:51 +00:00
if ( GetElementCount( AIntf. Members, TPasProcedure) > 0 ) then begin
2006-08-26 00:35:42 +00:00
WriteLn( '{ %s implementation }' , [ strClassName] ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethodDec( AMthd : TPasProcedure) ;
var
2006-08-26 00:35:42 +00:00
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prms : TList;
prm : TPasArgument;
begin
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
if AMthd. InheritsFrom( TPasFunction) then begin
2006-08-26 00:35:42 +00:00
Write( 'function ' ) ;
2007-06-24 23:33:51 +00:00
end else begin
Write( 'procedure ' ) ;
end ;
2006-08-26 00:35:42 +00:00
Write( '%s.%s(' , [ strClassName, AMthd. Name ] ) ;
2007-06-24 23:33:51 +00:00
if ( prmCnt > 0 ) then begin
2006-08-26 00:35:42 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( prmCnt) do begin
prm : = TPasArgument( prms[ k] ) ;
if ( k > 0 ) then
2006-08-26 00:35:42 +00:00
Write( '; ' ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
Write( '%s %s : %s' , [ AccessNames[ prm. Access] , prm. Name , prm. ArgType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
DecIndent( ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
Write( ')' ) ;
2007-06-24 23:33:51 +00:00
if AMthd. InheritsFrom( TPasFunction) then begin
Write( ':%s' , [ TPasFunctionType( AMthd. ProcType) . ResultEl. ResultType. Name ] ) ;
end ;
2006-08-26 00:35:42 +00:00
WriteLn( ';' ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
2007-06-24 23:33:51 +00:00
procedure WriteMethodImp( AMthd : TPasProcedure) ;
begin
2006-08-26 00:35:42 +00:00
WriteLn( 'Begin' ) ;
WriteLn( '// your code here' ) ;
WriteLn( 'End;' ) ;
2007-06-24 23:33:51 +00:00
end ;
2006-08-26 00:35:42 +00:00
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2006-08-26 00:35:42 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mbrs : TList;
elt : TPasElement;
mtd : TPasProcedure;
2006-08-26 00:35:42 +00:00
begin
2007-06-24 23:33:51 +00:00
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 ;
2006-08-26 00:35:42 +00:00
end ;
procedure GenerateRegistrationProc( ) ;
Var
strBuff : string ;
Begin
NewLine( ) ;
BeginAutoIndent( ) ;
strBuff : = ExtractserviceName( AIntf) ;
NewLine( ) ;
WriteLn( 'procedure Register%sImplementationFactory();' , [ strBuff] ) ;
WriteLn( 'Begin' ) ;
IncIndent( ) ;
WriteLn( 'GetServiceImplementationRegistry().Register(%s,TImplementationFactory.Create(%s) as IServiceImplementationFactory);' , [ QuotedStr( AIntf. Name ) , strClassName] ) ;
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
2007-06-24 23:33:51 +00:00
Result : = Format( '%s_imp' , [ SymbolTable. CurrentModule. Name ] ) ;
2006-08-26 00:35:42 +00:00
end ;
2007-06-24 23:33:51 +00:00
constructor TImplementationGenerator. Create( ASymTable: TwstPasTreeContainer; ASrcMngr: ISourceManager) ;
2006-08-26 00:35:42 +00:00
begin
Inherited Create( ASymTable, ASrcMngr) ;
FDecStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.dec' ) ;
FImpStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.imp' ) ;
end ;
procedure TImplementationGenerator. Execute( ) ;
Var
i, c : Integer ;
2007-06-24 23:33:51 +00:00
intf : TPasClassType;
elt : TPasElement;
typeList : TList;
2006-08-26 00:35:42 +00:00
begin
GenerateUnitHeader( ) ;
GenerateUnitImplementationHeader( ) ;
2007-07-12 14:46:45 +00:00
typeList : = SymbolTable. CurrentModule. InterfaceSection. Declarations;
2007-06-24 23:33:51 +00:00
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) ;
2006-08-26 00:35:42 +00:00
GenerateIntf( intf) ;
GenerateImp( intf) ;
2007-06-24 23:33:51 +00:00
end ;
end ;
2006-08-26 00:35:42 +00:00
GenerateUnitImplementationFooter( ) ;
FSrcMngr. Merge( GetDestUnitName( ) + '.pas' , [ FDecStream, FImpStream] ) ;
2007-06-24 23:33:51 +00:00
FDecStream : = nil ;
FImpStream : = nil ;
2006-08-26 00:35:42 +00:00
end ;
2007-03-23 23:22:35 +00:00
{ TInftGenerator }
2007-06-24 23:33:51 +00:00
function TInftGenerator. GenerateIntfName( AIntf: TPasElement) : string ;
2007-03-23 23:22:35 +00:00
begin
Result : = ExtractserviceName( AIntf) ;
end ;
procedure TInftGenerator. GenerateUnitHeader( ) ;
begin
SetCurrentStream( FDecStream) ;
WriteLn( '{' ) ;
WriteLn( 'This unit has been produced by ws_helper.' ) ;
2007-06-24 23:33:51 +00:00
WriteLn( ' Input unit name : "%s".' , [ SymbolTable. CurrentModule. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( ' This unit name : "%s".' , [ GetDestUnitName( ) ] ) ;
WriteLn( ' Date : "%s".' , [ DateTimeToStr( Now( ) ) ] ) ;
WriteLn( '}' ) ;
WriteLn( 'unit %s;' , [ GetDestUnitName( ) ] ) ;
2007-05-05 19:05:01 +00:00
WriteLn( '{$IFDEF FPC} {$mode objfpc}{$H+} {$ENDIF}' ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'interface' ) ;
WriteLn( '' ) ;
WriteLn( 'uses SysUtils, Classes, TypInfo, base_service_intf, service_intf;' ) ;
WriteLn( '' ) ;
WriteLn( 'const' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'sNAME_SPACE = %s;' , [ QuotedStr( SymbolTable. GetExternalName( FSymbolTable. CurrentModule) ) ] ) ;
Indent( ) ; WriteLn( 'sUNIT_NAME = %s;' , [ QuotedStr( FSymbolTable. CurrentModule. Name ) ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
WriteLn( '' ) ;
WriteLn( 'type' ) ;
WriteLn( '' ) ;
end ;
procedure TInftGenerator. GenerateUnitImplementationHeader( ) ;
begin
SetCurrentStream( FImpStream) ;
WriteLn( '' ) ;
WriteLn( 'Implementation' ) ;
2007-03-25 23:47:16 +00:00
WriteLn( 'uses metadata_repository;' ) ;
2007-03-23 23:22:35 +00:00
FImpTempStream. WriteLn( 'initialization' ) ;
end ;
procedure TInftGenerator. GenerateUnitImplementationFooter( ) ;
begin
SetCurrentStream( FImpStream) ;
NewLine( ) ;
NewLine( ) ;
FImpTempStream. NewLine( ) ;
2007-04-17 00:52:02 +00:00
FImpLastStream. NewLine( ) ;
FImpLastStream. WriteLn( 'End.' ) ;
2007-03-23 23:22:35 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure TInftGenerator. GenerateIntf( AIntf: TPasClassType) ;
2007-03-23 23:22:35 +00:00
procedure WriteDec( ) ;
begin
Indent( ) ;
2007-04-26 23:23:41 +00:00
WriteLn( '%s = interface(IInvokable)' , [ GenerateIntfName( AIntf) ] ) ;
2007-04-02 13:19:48 +00:00
if not IsStrEmpty( AIntf. InterfaceGUID) then begin
Indent( ) ; Indent( ) ; WriteLn( '[%s]' , [ QuotedStr( AIntf. InterfaceGUID) ] ) ;
end ;
2007-03-23 23:22:35 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure WriteMethod( AMthd : TPasProcedure) ;
var
2007-03-23 23:22:35 +00:00
prmCnt, k : Integer ;
2007-06-24 23:33:51 +00:00
prm : TPasArgument;
prms : TList;
begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
2007-06-24 23:33:51 +00:00
prms : = AMthd. ProcType. Args;
prmCnt : = prms. Count;
if AMthd. InheritsFrom( TPasFunction) then begin
2007-03-23 23:22:35 +00:00
Write( 'function ' ) ;
2007-06-24 23:33:51 +00:00
end else begin
Write( 'procedure ' ) ;
end ;
2007-03-23 23:22:35 +00:00
Write( '%s(' , [ AMthd. Name ] ) ;
2007-06-24 23:33:51 +00:00
if ( prmCnt > 0 ) then begin
2007-03-23 23:22:35 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( prmCnt) do begin
prm : = TPasArgument( prms[ k] ) ;
if ( k > 0 ) then
2007-03-23 23:22:35 +00:00
Write( '; ' ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
Write( '%s %s : %s' , [ AccessNames[ prm. Access] , prm. Name , prm. ArgType. Name ] ) ;
end ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
NewLine( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
end ;
2007-03-23 23:22:35 +00:00
Write( ')' ) ;
2007-06-24 23:33:51 +00:00
if AMthd. InheritsFrom( TPasFunction) then begin
Write( ':%s' , [ TPasFunctionType( AMthd. ProcType) . ResultEl. ResultType. Name ] ) ;
end ;
2007-03-23 23:22:35 +00:00
WriteLn( ';' ) ;
2007-06-24 23:33:51 +00:00
end ;
2007-03-23 23:22:35 +00:00
procedure WriteMethods( ) ;
2007-06-24 23:33:51 +00:00
var
2007-03-23 23:22:35 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
mbrs : TList;
elt : TPasElement;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
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( ) ;
2007-03-23 23:22:35 +00:00
end ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
WriteDec( ) ;
WriteMethods( ) ;
Indent( ) ; WriteLn( 'end;' ) ;
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
procedure TInftGenerator. GenerateTypeAlias( ASymbol: TPasAliasType) ;
var
typeModifier : string ;
2007-03-23 23:22:35 +00:00
begin
try
SetCurrentStream( FDecStream) ;
2007-06-24 23:33:51 +00:00
if ASymbol. InheritsFrom( TPasTypeAliasType) then begin
typeModifier : = 'type ' ;
end else begin
typeModifier : = '' ;
end ;
2007-03-23 23:22:35 +00:00
NewLine( ) ;
IncIndent( ) ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( '%s = %s%s;' , [ ASymbol. Name , typeModifier, ASymbol. DestType. Name ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
except
on e : Exception do
2007-06-24 23:33:51 +00:00
GetLogger. Log( mtError, 'TInftGenerator.GenerateTypeAlias()=' , [ ASymbol. Name , ' ;; ' , e. Message ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
2007-06-24 23:33:51 +00:00
procedure TInftGenerator. GenerateClass( ASymbol: TPasClassType) ;
2007-03-23 23:22:35 +00:00
var
2007-06-24 23:33:51 +00:00
locClassPropNbr, locOptionalPropsNbr, locArrayPropsNbr, locPropCount : Integer ;
locPropList : TObjectList;
2007-03-23 23:22:35 +00:00
procedure Prepare( ) ;
var
k : Integer ;
2007-06-24 23:33:51 +00:00
elt : TPasElement;
p : TPasProperty;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
locPropCount : = 0 ;
2007-03-23 23:22:35 +00:00
locClassPropNbr : = 0 ;
2007-04-17 00:52:02 +00:00
locArrayPropsNbr : = 0 ;
2007-06-24 23:33:51 +00:00
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( 'HAS' , Copy( p. StoredAccessorName, 1 , 3 ) ) then
Inc( locOptionalPropsNbr) ;
end ;
2007-03-23 23:22:35 +00:00
end ;
2007-04-17 00:52:02 +00:00
locClassPropNbr : = locClassPropNbr + locArrayPropsNbr;
2007-03-23 23:22:35 +00:00
end ;
procedure WriteDec( ) ;
var
2007-06-24 23:33:51 +00:00
decBuffer, s : string ;
elt : TPasElement;
ultimAnc, trueAncestor : TPasType;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
if Assigned( ASymbol. AncestorType) then begin
trueAncestor : = ASymbol. AncestorType;
if trueAncestor. InheritsFrom( TPasUnresolvedTypeRef) then begin
elt : = SymbolTable. FindElement( SymbolTable. GetExternalName( trueAncestor) ) ;
if elt. InheritsFrom( TPasType) then begin
trueAncestor : = TPasType( elt) ;
end ;
end ;
ultimAnc : = GetUltimeType( trueAncestor) ;
if ultimAnc. InheritsFrom( TPasNativeSimpleType) then begin
trueAncestor : = ultimAnc;
end ;
if trueAncestor. InheritsFrom( TPasNativeSimpleType) and
Assigned( TPasNativeSimpleType( trueAncestor) . BoxedType)
2007-03-23 23:22:35 +00:00
then begin
2007-06-24 23:33:51 +00:00
trueAncestor : = TPasNativeSimpleType( trueAncestor) . BoxedType;
end ;
s : = Format( '%s' , [ trueAncestor. Name ] ) ;
end else begin
s : = '' ; //'TBaseComplexRemotable';
end ;
if IsStrEmpty( s) then begin
decBuffer : = '' ;
2007-03-23 23:22:35 +00:00
end else begin
2007-06-24 23:33:51 +00:00
decBuffer : = Format( '(%s)' , [ s] ) ;
2007-03-23 23:22:35 +00:00
end ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( '%s = class%s' , [ ASymbol. Name , decBuffer] ) ;
2007-03-23 23:22:35 +00:00
end ;
2007-06-24 23:33:51 +00:00
procedure WritePropertyField( AProp : TPasProperty) ;
2007-03-23 23:22:35 +00:00
begin
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'F%s : %s;' , [ AProp. Name , AProp. VarType. Name ] ) ;
2007-03-23 23:22:35 +00:00
End ;
2007-06-24 23:33:51 +00:00
procedure WriteProperty( AProp : TPasProperty) ;
2007-03-23 23:22:35 +00:00
var
propName, locStore : string ;
begin
propName : = AProp. Name ;
2007-06-24 23:33:51 +00:00
if AnsiSameText( 'True' , AProp. StoredAccessorName) then begin
locStore : = '' ;
end else begin
locStore : = Format( ' stored %s' , [ AProp. StoredAccessorName] ) ;
2007-03-23 23:22:35 +00:00
end ;
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'property %s : %s read F%s write F%s%s;' , [ propName, AProp. VarType. Name , propName, propName, locStore] ) ;
if not AnsiSameText( AProp. Name , SymbolTable. GetExternalName( AProp) ) then begin
2007-04-17 00:52:02 +00:00
FImpLastStream. Indent( ) ;
2007-06-24 23:33:51 +00:00
FImpLastStream. WriteLn( 'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);' , [ ASymbol. Name , QuotedStr( AProp. Name ) , QuotedStr( SymbolTable. GetExternalName( AProp) ) ] ) ;
2007-03-23 23:22:35 +00:00
end ;
2007-06-24 23:33:51 +00:00
if SymbolTable. IsAttributeProperty( AProp) then begin
2007-04-17 00:52:02 +00:00
FImpLastStream. Indent( ) ;
FImpLastStream. WriteLn( '%s.RegisterAttributeProperty(%s);' , [ ASymbol. Name , QuotedStr( AProp. Name ) ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
procedure WriteProperties( ) ;
2007-06-24 23:33:51 +00:00
var
2007-03-23 23:22:35 +00:00
k : Integer ;
2007-06-24 23:33:51 +00:00
p : TPasProperty;
2007-07-07 20:56:01 +00:00
//pt : TPasElement;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
if ( locPropCount > 0 ) then begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
WriteLn( 'private' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( locPropCount) do begin
p : = TPasProperty( locPropList[ k] ) ;
2007-07-07 20:56:01 +00:00
{ if p. VarType. InheritsFrom( TPasUnresolvedTypeRef) then begin
2007-06-24 23:33:51 +00:00
pt : = SymbolTable. FindElement( SymbolTable. GetExternalName( p. VarType) ) ;
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 ;
2007-07-07 20:56:01 +00:00
end ; }
2007-03-23 23:22:35 +00:00
WritePropertyField( p) ;
end ;
DecIndent( ) ;
//
2007-06-24 23:33:51 +00:00
if ( locOptionalPropsNbr > 0 ) then begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
WriteLn( 'private' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( locPropCount) do begin
p : = TPasProperty( locPropList[ k] ) ;
if AnsiSameText( 'HAS' , Copy( p. StoredAccessorName, 1 , 3 ) ) then begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'function %s() : Boolean;' , [ p. StoredAccessorName] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
DecIndent( ) ;
end ;
//
2007-04-17 00:52:02 +00:00
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
WriteLn( 'public' ) ;
2007-04-17 00:52:02 +00:00
end ;
2007-06-24 23:33:51 +00:00
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
2007-03-23 23:22:35 +00:00
IncIndent( ) ;
2007-04-17 00:52:02 +00:00
Indent( ) ; WriteLn( 'constructor Create();override;' ) ;
DecIndent( ) ;
end ;
2007-06-24 23:33:51 +00:00
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
2007-04-17 00:52:02 +00:00
IncIndent( ) ;
Indent( ) ; WriteLn( 'destructor Destroy();override;' ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
end ;
//
Indent( ) ;
WriteLn( 'published' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
For k : = 0 To Pred( locPropCount) Do
WriteProperty( TPasProperty( locPropList[ k] ) ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
end ;
end ;
procedure WriteImp( ) ;
var
k : Integer ;
2007-06-24 23:33:51 +00:00
p : TPasProperty;
ss : string ;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
if ( locClassPropNbr > 0 ) then begin
2007-03-23 23:22:35 +00:00
NewLine( ) ;
WriteLn( '{ %s }' , [ ASymbol. Name ] ) ;
2007-06-24 23:33:51 +00:00
if ( locClassPropNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
2007-04-17 00:52:02 +00:00
NewLine( ) ;
WriteLn( 'constructor %s.Create();' , [ ASymbol. Name ] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
Indent( ) ;
WriteLn( 'inherited Create();' ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( locPropCount) do begin
p : = TPasProperty( locPropList[ k] ) ;
if SymbolTable. IsOfType( p. VarType, TPasClassType) or
SymbolTable. IsOfType( p. VarType, TPasArrayType)
then begin
2007-04-17 00:52:02 +00:00
Indent( ) ;
2007-06-24 23:33:51 +00:00
if AnsiSameText( p. Name , p. VarType. Name ) or
( SymbolTable. IsOfType( p. VarType, TPasClassType) and Assigned( FindMember( TPasClassType( ASymbol) , p. VarType. Name ) ) )
then
ss : = Format( '%s.%s' , [ SymbolTable. CurrentModule. Name , p. VarType. Name ] )
else
ss : = p. VarType. Name ;
WriteLn( 'F%s := %s.Create();' , [ p. Name , ss{p.VarType.Name} ] ) ;
2007-04-17 00:52:02 +00:00
end ;
end ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
end ;
2007-06-24 23:33:51 +00:00
if ( locArrayPropsNbr > 0 ) or ( locClassPropNbr > 0 ) then begin
2007-03-23 23:22:35 +00:00
NewLine( ) ;
WriteLn( 'destructor %s.Destroy();' , [ ASymbol. Name ] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for k : = 0 to Pred( locPropCount) do begin
p : = TPasProperty( locPropList[ k] ) ;
if SymbolTable. IsOfType( p. VarType, TPasClassType) or
SymbolTable. IsOfType( p. VarType, TPasArrayType)
then begin
2007-03-23 23:22:35 +00:00
Indent( ) ;
WriteLn( 'if Assigned(F%s) then' , [ p. Name ] ) ;
IncIndent( ) ;
Indent( ) ;
WriteLn( 'FreeAndNil(F%s);' , [ p. Name ] ) ;
DecIndent( ) ;
end ;
end ;
Indent( ) ;
WriteLn( 'inherited Destroy();' ) ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
end ;
2007-06-24 23:33:51 +00:00
end ;
for k : = 0 to Pred( locPropCount) do begin
p : = TPasProperty( locPropList[ k] ) ;
if AnsiSameText( 'HAS' , Copy( p. StoredAccessorName, 1 , 3 ) ) then begin
NewLine( ) ;
WriteLn( 'function %s.%s() : Boolean;' , [ ASymbol. Name , p. StoredAccessorName] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
Indent( ) ;
WriteLn( 'Result := True;' ) ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
end ;
begin
2007-06-24 23:33:51 +00:00
locPropList : = TObjectList. Create( False ) ;
2007-03-23 23:22:35 +00:00
try
2007-06-24 23:33:51 +00:00
Prepare( ) ;
try
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
WriteDec( ) ;
WriteProperties( ) ;
Indent( ) ; WriteLn( 'end;' ) ;
DecIndent( ) ;
2007-03-23 23:22:35 +00:00
2007-06-24 23:33:51 +00:00
FImpTempStream. Indent( ) ;
FImpTempStream. WriteLn( 'GetTypeRegistry().Register(%s,TypeInfo(%s),%s);' , [ sNAME_SPACE, ASymbol. Name , QuotedStr( SymbolTable. GetExternalName( ASymbol) ) ] ) ;
SetCurrentStream( FImpStream) ;
WriteImp( ) ;
except
on e : Exception do begin
GetLogger. Log( mtError, 'TInftGenerator.GenerateClass()=' , [ ASymbol. Name , ' ;; ' , e. Message ] ) ;
raise ;
end ;
end ;
finally
FreeAndNil( locPropList) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
2007-06-24 23:33:51 +00:00
procedure TInftGenerator. GenerateEnum( ASymbol: TPasEnumType) ;
2007-03-23 23:22:35 +00:00
var
2007-06-24 23:33:51 +00:00
itm : TPasEnumValue;
2007-03-23 23:22:35 +00:00
i : Integer ;
begin
try
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( '%s = ( ' , [ ASymbol. Name ] ) ;
FImpTempStream. Indent( ) ;
2007-06-24 23:33:51 +00:00
FImpTempStream. WriteLn( 'GetTypeRegistry().Register(%s,TypeInfo(%s),%s);' , [ sNAME_SPACE, ASymbol. Name , QuotedStr( SymbolTable. GetExternalName( ASymbol) ) ] ) ;
2007-03-23 23:22:35 +00:00
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
for i : = 0 to Pred( ASymbol. Values. Count) do begin
itm : = TPasEnumValue( ASymbol. Values[ i] ) ;
2007-03-23 23:22:35 +00:00
Indent( ) ;
if ( i > 0 ) then
WriteLn( ',%s' , [ itm. Name ] )
else
WriteLn( '%s' , [ itm. Name ] ) ;
2007-06-24 23:33:51 +00:00
if not AnsiSameText( itm. Name , SymbolTable. GetExternalName( itm) ) then begin
2007-03-23 23:22:35 +00:00
FImpTempStream. Indent( ) ;
2007-06-24 23:33:51 +00:00
FImpTempStream. WriteLn( 'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(%s,%s);' , [ ASymbol. Name , QuotedStr( itm. Name ) , QuotedStr( SymbolTable. GetExternalName( itm) ) ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
DecIndent( ) ;
Indent( ) ; WriteLn( ');' ) ;
DecIndent( ) ;
except
on e : Exception do
2007-06-24 23:33:51 +00:00
GetLogger. Log( mtError, 'TInftGenerator.GenerateClass()=' , [ ASymbol. Name , ' ;; ' , e. Message ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
2007-06-24 23:33:51 +00:00
procedure TInftGenerator. GenerateArray( ASymbol: TPasArrayType) ;
2007-03-23 23:22:35 +00:00
procedure WriteObjectArray( ) ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
BeginAutoIndent( ) ;
try
WriteLn( '%s = class(TBaseObjectArrayRemotable)' , [ ASymbol. Name ] ) ;
WriteLn( 'private' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'function GetItem(AIndex: Integer): %s;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'public' ) ;
Indent( ) ; WriteLn( 'class function GetItemClass():TBaseRemotableClass;override;' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'property Item[AIndex:Integer] : %s Read GetItem;Default;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'end;' ) ;
finally
EndAutoIndent( ) ;
DecIndent( ) ;
end ;
SetCurrentStream( FImpStream) ;
NewLine( ) ;
WriteLn( '{ %s }' , [ ASymbol. Name ] ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'function %s.GetItem(AIndex: Integer): %s;' , [ ASymbol. Name , ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'begin' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'Result := Inherited GetItem(AIndex) As %s;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
WriteLn( 'end;' ) ;
NewLine( ) ;
WriteLn( 'class function %s.GetItemClass(): TBaseRemotableClass;' , [ ASymbol. Name ] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'Result:= %s;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
WriteLn( 'end;' ) ;
end ;
procedure WriteSimpleTypeArray( ) ;
begin
SetCurrentStream( FDecStream) ;
NewLine( ) ;
IncIndent( ) ;
BeginAutoIndent( ) ;
try
WriteLn( '%s = class(TBaseSimpleTypeArrayRemotable)' , [ ASymbol. Name ] ) ;
WriteLn( 'private' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'FData : array of %s;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'private' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'function GetItem(AIndex: Integer): %s;' , [ ASymbol. ElType. Name ] ) ;
Indent( ) ; WriteLn( 'procedure SetItem(AIndex: Integer; const AValue: %s);' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
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;' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'property Item[AIndex:Integer] : %s read GetItem write SetItem; default;' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'end;' ) ;
finally
EndAutoIndent( ) ;
DecIndent( ) ;
end ;
SetCurrentStream( FImpStream) ;
NewLine( ) ;
WriteLn( '{ %s }' , [ ASymbol. Name ] ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'function %s.GetItem(AIndex: Integer): %s;' , [ ASymbol. Name , ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
WriteLn( 'begin' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( 'CheckIndex(AIndex);' ) ;
Indent( ) ; WriteLn( 'Result := FData[AIndex];' ) ;
DecIndent( ) ;
WriteLn( 'end;' ) ;
NewLine( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'procedure %s.SetItem(AIndex: Integer;const AValue: %S);' , [ ASymbol. Name , ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
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( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'AStore.Put(%s,TypeInfo(%s),FData[AIndex]);' , [ QuotedStr( SymbolTable. GetArrayItemName( ASymbol) ) , ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
WriteLn( 'end;' ) ;
NewLine( ) ;
IncIndent( ) ;
WriteLn( 'procedure %s.LoadItem(AStore: IFormatterBase;const AIndex: Integer);' , [ ASymbol. Name ] ) ;
WriteLn( 'var' ) ;
Indent( ) ; WriteLn( 'sName : string;' ) ;
WriteLn( 'begin' ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'sName := %s;' , [ QuotedStr( SymbolTable. GetArrayItemName( ASymbol) ) ] ) ;
Indent( ) ; WriteLn( 'AStore.Get(TypeInfo(%s),sName,FData[AIndex]);' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
DecIndent( ) ;
WriteLn( 'end;' ) ;
NewLine( ) ;
WriteLn( 'class function %s.GetItemTypeInfo(): PTypeInfo;' , [ ASymbol. Name ] ) ;
WriteLn( 'begin' ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'Result := TypeInfo(%s);' , [ ASymbol. ElType. Name ] ) ;
2007-03-23 23:22:35 +00:00
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;' ) ;
end ;
var
classItemArray : Boolean ;
2007-06-24 23:33:51 +00:00
eltType : TPasType;
2007-03-23 23:22:35 +00:00
begin
2007-06-24 23:33:51 +00:00
eltType : = ASymbol. ElType;
if eltType. InheritsFrom( TPasUnresolvedTypeRef) then begin
eltType : = SymbolTable. FindElement( SymbolTable. GetExternalName( eltType) ) as TPasType;
end ;
classItemArray : = SymbolTable. IsOfType( eltType, TPasClassType) or SymbolTable. IsOfType( eltType, TPasArrayType) ;
2007-03-23 23:22:35 +00:00
if classItemArray then begin
WriteObjectArray( ) ;
end else begin
WriteSimpleTypeArray( ) ;
end ;
2007-06-24 23:33:51 +00:00
2007-03-23 23:22:35 +00:00
FImpTempStream. Indent( ) ;
2007-06-24 23:33:51 +00:00
FImpTempStream. WriteLn( 'GetTypeRegistry().Register(%s,TypeInfo(%s),%s);' , [ sNAME_SPACE, ASymbol. Name , QuotedStr( SymbolTable. GetExternalName( ASymbol) ) ] ) ;
if ( SymbolTable. GetArrayItemName( ASymbol) < > SymbolTable. GetArrayItemExternalName( ASymbol) ) then begin
2007-04-02 13:19:48 +00:00
FImpTempStream. Indent( ) ;
FImpTempStream. WriteLn(
'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(sARRAY_ITEM,%s);' ,
2007-06-24 23:33:51 +00:00
[ ASymbol. Name , QuotedStr( SymbolTable. GetArrayItemExternalName( ASymbol) ) ]
2007-04-02 13:19:48 +00:00
) ;
end ;
2007-06-24 23:33:51 +00:00
if ( SymbolTable. GetArrayStyle( ASymbol) = asEmbeded ) then begin
2007-04-02 13:19:48 +00:00
FImpTempStream. Indent( ) ;
2007-03-25 23:47:16 +00:00
FImpTempStream. WriteLn(
2007-04-02 13:19:48 +00:00
'GetTypeRegistry().ItemByTypeInfo[TypeInfo(%s)].RegisterExternalPropertyName(sARRAY_STYLE,sEmbedded);' ,
2007-06-24 23:33:51 +00:00
[ ASymbol. Name , QuotedStr( SymbolTable. GetArrayItemExternalName( ASymbol) ) ]
2007-03-25 23:47:16 +00:00
) ;
end ;
end ;
procedure TInftGenerator. GenerateCustomMetadatas( ) ;
2007-06-24 23:33:51 +00:00
procedure WriteOperationDatas( AInftDef : TPasClassType; AOp : TPasProcedure) ;
2007-03-25 23:47:16 +00:00
var
k : Integer ;
pl : TStrings;
begin
2007-06-24 23:33:51 +00:00
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 ;
2007-03-25 23:47:16 +00:00
end ;
end ;
end ;
2007-06-24 23:33:51 +00:00
procedure WriteServiceDatas( ABinding : TwstBinding) ;
2007-03-25 23:47:16 +00:00
var
k : Integer ;
2007-06-24 23:33:51 +00:00
opList : TList;
elt : TPasElement;
2007-03-25 23:47:16 +00:00
begin
2007-06-24 23:33:51 +00:00
if not IsStrEmpty( ABinding. Address) then begin
2007-03-25 23:47:16 +00:00
Indent( ) ; WriteLn( 'mm.SetServiceCustomData(' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( '%s,' , [ sUNIT_NAME] ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( ABinding. Intf. Name ) ] ) ;
2007-04-26 23:23:41 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( 'TRANSPORT_Address' ) ] ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s' , [ QuotedStr( ABinding. Address) ] ) ;
2007-03-25 23:47:16 +00:00
DecIndent( ) ;
Indent( ) ; WriteLn( ');' ) ;
end ;
2007-04-12 00:48:00 +00:00
2007-06-24 23:33:51 +00:00
if ( ABinding. BindingStyle = bsRPC ) then begin
2007-04-12 00:48:00 +00:00
Indent( ) ; WriteLn( 'mm.SetServiceCustomData(' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( '%s,' , [ sUNIT_NAME] ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( ABinding. Intf. Name ) ] ) ;
2007-04-26 23:23:41 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( 'FORMAT_Style' ) ] ) ;
2007-04-12 00:48:00 +00:00
Indent( ) ; WriteLn( '%s' , [ QuotedStr( 'rpc' ) ] ) ;
DecIndent( ) ;
Indent( ) ; WriteLn( ');' ) ;
2007-06-24 23:33:51 +00:00
end else if ( ABinding. BindingStyle = bsDocument ) then begin
2007-04-17 00:52:02 +00:00
Indent( ) ; WriteLn( 'mm.SetServiceCustomData(' ) ;
IncIndent( ) ;
Indent( ) ; WriteLn( '%s,' , [ sUNIT_NAME] ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( ABinding. Intf. Name ) ] ) ;
2007-04-26 23:23:41 +00:00
Indent( ) ; WriteLn( '%s,' , [ QuotedStr( 'FORMAT_Style' ) ] ) ;
2007-04-17 00:52:02 +00:00
Indent( ) ; WriteLn( '%s' , [ QuotedStr( 'document' ) ] ) ;
DecIndent( ) ;
Indent( ) ; WriteLn( ');' ) ;
2007-04-12 00:48:00 +00:00
end ;
2007-03-25 23:47:16 +00:00
2007-06-24 23:33:51 +00:00
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 ;
2007-03-25 23:47:16 +00:00
end ;
end ;
var
i : Integer ;
begin
SetCurrentStream( FImpStream) ;
IncIndent( ) ;
NewLine( ) ; NewLine( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( 'procedure Register_%s_ServiceMetadata();' , [ SymbolTable. CurrentModule. Name ] ) ;
2007-03-25 23:47:16 +00:00
WriteLn( 'var' ) ;
Indent( ) ; WriteLn( 'mm : IModuleMetadataMngr;' ) ;
WriteLn( 'begin' ) ;
Indent( ) ; WriteLn( 'mm := GetModuleMetadataMngr();' ) ;
Indent( ) ; WriteLn( 'mm.SetRepositoryNameSpace(%s, %s);' , [ sUNIT_NAME, sNAME_SPACE] ) ;
2007-06-24 23:33:51 +00:00
for i : = 0 to Pred( SymbolTable. BindingCount) do begin
WriteServiceDatas( SymbolTable. Binding[ i] ) ;
2007-03-25 23:47:16 +00:00
end ;
WriteLn( 'end;' ) ;
DecIndent( ) ;
2007-03-23 23:22:35 +00:00
end ;
function TInftGenerator. GetDestUnitName( ) : string ;
begin
2007-06-24 23:33:51 +00:00
Result : = SymbolTable. CurrentModule. Name ;
2007-03-23 23:22:35 +00:00
end ;
constructor TInftGenerator. Create(
2007-06-24 23:33:51 +00:00
ASymTable : TwstPasTreeContainer;
2007-03-23 23:22:35 +00:00
ASrcMngr : ISourceManager
) ;
begin
inherited Create( ASymTable, ASrcMngr) ;
FDecStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.dec' ) ;
FImpStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.imp' ) ;
FImpTempStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.tmp_imp' ) ;
2007-04-17 00:52:02 +00:00
FImpLastStream : = SrcMngr. CreateItem( GetDestUnitName( ) + '.tmp_imp_last' ) ;
2007-03-23 23:22:35 +00:00
FImpTempStream. IncIndent( ) ;
2007-04-17 00:52:02 +00:00
FImpLastStream. IncIndent( ) ;
2007-03-23 23:22:35 +00:00
end ;
procedure TInftGenerator. Execute( ) ;
var
i, c, j, k : Integer ;
2007-06-24 23:33:51 +00:00
clssTyp : TPasClassType;
2007-03-23 23:22:35 +00:00
gnrClssLst : TObjectList;
objLst : TObjectList;
2007-06-24 23:33:51 +00:00
typeList : TList;
elt : TPasElement;
classAncestor : TPasElement;
2007-03-23 23:22:35 +00:00
begin
objLst : = nil ;
gnrClssLst : = TObjectList. Create( False ) ;
try
GenerateUnitHeader( ) ;
GenerateUnitImplementationHeader( ) ;
2007-07-12 14:46:45 +00:00
typeList : = SymbolTable. CurrentModule. InterfaceSection. Declarations;
2007-06-24 23:33:51 +00:00
c : = Pred( typeList. Count) ;
2007-03-23 23:22:35 +00:00
SetCurrentStream( FDecStream) ;
IncIndent( ) ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasUnresolvedTypeRef) then begin
WriteLn( '// %s = unable to resolve this symbol.' , [ elt. Name ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
DecIndent( ) ;
IncIndent( ) ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
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)
)
2007-03-23 23:22:35 +00:00
then begin
Indent( ) ;
2007-06-24 23:33:51 +00:00
WriteLn( '%s = class;' , [ elt. Name ] ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
DecIndent( ) ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasEnumType) then begin
GenerateEnum( TPasEnumType( elt) ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasAliasType) then begin
GenerateTypeAlias( TPasAliasType( elt) ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
objLst : = TObjectList. Create( ) ;
objLst. OwnsObjects : = False ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasClassType) and ( TPasClassType( elt) . ObjKind = okClass ) then begin
clssTyp : = TPasClassType( elt) ;
2007-03-23 23:22:35 +00:00
if ( gnrClssLst. IndexOf( clssTyp) = - 1 ) then begin
while ( objLst. Count > 0 ) do begin
objLst. Clear( ) ;
end ;
while Assigned( clssTyp) do begin
objLst. Add( clssTyp) ;
2007-06-24 23:33:51 +00:00
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;
2007-03-23 23:22:35 +00:00
end else begin
clssTyp : = nil ;
end ;
end ;
k : = Pred( objLst. Count) ;
for j : = 0 to k do begin
2007-06-24 23:33:51 +00:00
clssTyp : = objLst[ k- j] as TPasClassType;
2007-03-23 23:22:35 +00:00
if ( gnrClssLst. IndexOf( clssTyp) = - 1 ) then begin
2007-07-12 14:46:45 +00:00
if ( FSymbolTable. CurrentModule. InterfaceSection. Declarations. IndexOf( clssTyp) < > - 1 ) then begin
2007-03-23 23:22:35 +00:00
GenerateClass( clssTyp) ;
gnrClssLst. Add( clssTyp) ;
end ;
end ;
end ;
end ;
end ;
end ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasArrayType) then begin
GenerateArray( TPasArrayType( elt) ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
for i : = 0 to c do begin
2007-06-24 23:33:51 +00:00
elt : = TPasElement( typeList[ i] ) ;
if elt. InheritsFrom( TPasClassType) and ( TPasClassType( elt) . ObjKind = okInterface ) then begin
GenerateIntf( TPasClassType( elt) ) ;
2007-03-23 23:22:35 +00:00
end ;
end ;
2007-03-25 23:47:16 +00:00
NewLine( ) ;
IncIndent( ) ;
2007-06-24 23:33:51 +00:00
Indent( ) ; WriteLn( 'procedure Register_%s_ServiceMetadata();' , [ SymbolTable. CurrentModule. Name ] ) ;
2007-03-25 23:47:16 +00:00
DecIndent( ) ;
GenerateCustomMetadatas( ) ;
2007-03-23 23:22:35 +00:00
GenerateUnitImplementationFooter( ) ;
2007-04-17 00:52:02 +00:00
FSrcMngr. Merge( GetDestUnitName( ) + '.pas' , [ FDecStream, FImpStream, FImpTempStream, FImpLastStream] ) ;
2007-03-23 23:22:35 +00:00
FDecStream : = nil ;
FImpStream : = nil ;
FImpTempStream : = nil ;
finally
FreeAndNil( objLst) ;
FreeAndNil( gnrClssLst) ;
end ;
end ;
2006-08-26 00:35:42 +00:00
end .