$MACRO
{main_s}
{main_c}
$END

$MACRO main_S
$loop Modules
unit {ModuleName}_SRV;
{directives}
interface
uses SysUtils, CorbaObj, OrbPas{Macro|include_s};

type
{Macro|redef_s}
  // -- Forward interface declarations
{Forwards}
{Constants}
{Interfaces_S}
procedure Init(InstanceName: string);

implementation
uses
  ComObj, eThreadInfo{Macro|include2_s};

var
  instance: string;

// -- Skeleton class implementations
{SkeletonImpls1}
procedure Init(instancename: string);
begin
//~  Obj__SRV.Init( UpperCase( instancename ) );
  instance := UpperCase(instancename);
{Registration_S}
end;
end.
$END main_S

$MACRO main_C
$loop Modules
unit {ModuleName}_CLT;
{directives}
interface
uses SysUtils, CorbaObj, OrbPas{Macro|include_c};

type
  EBowException = class (Exception)
  private
    FCode: integer;
  public
    constructor Create(fullMessage: string);
    property Code: integer read FCode write FCode;
  end;

{Macro|redef_c}
  // -- Forward interface declarations
{Forwards}
{Constants}
{Interfaces_C}
  // -- Factory declarations
{Factories}
procedure SetInstance(name: string);
procedure Init(instancename: string);

implementation
uses ComObj{CodeSite}, rzCsIntf{CodeSiteEnd};
var  instance: string;
{CodeSite}
var
  CodeSiteCount : integer;
procedure CodeSiteEnterMethod( str: string );
begin
  CodeSite.EnterMethod( str );
end;
procedure CodeSiteExitMethod( str: string );
begin
  CodeSite.ExitMethod( str );
  inc(CodeSiteCount);
  if CodeSiteCount > 10000 then
  begin
    CodeSiteCount := 0;
    CodeSite.Clear;
  end;
end;
{CodeSiteEnd}

constructor EBowException.Create(fullMessage: string);
begin
  try
    FCode := StrToInt( copy( fullMessage, 1, pos(' ', fullMessage)-1 ) );
    Message := copy( fullMessage, pos(' ', fullMessage)+1, length(fullMessage) );
  except
    FCode := 0;
    Message := fullMessage;
  end;
end;

{IntToPrincipal}
// -- Stub implementations
{StubImpls}
// -- Factory implementations
{FactoryImpls}
procedure SetInstance(name: string);
begin
  instance := UpperCase(name);
  {Macro|SetInstance_c}
end;

procedure Init(instancename: string);
begin
  {Macro|Init_c}
  instance := UpperCase(instancename);
{Registration_C}
end;

end.
$END main_C

$MACRO Directives
$find @
$replace {$TYPEDADDRESS OFF}
@
$END Directives

$MACRO CodeSite
$find @
$replace {$IfDef CodeSite}
@
$END CodeSite

$MACRO CodeSiteEnd
$find @
$replace {$EndIf}
@
$END CodeSiteEnd

$MACRO Forwards
$loop Interfaces
  I{InterfaceName} = interface;
$END Forwards

$MACRO Constants
$loop Constants
$find "
$replace '
  {ConstantName} = {ConstantValue};
$END Constants

$MACRO Interfaces_S
$loop Interfaces
$find TCorbaDispatchSkeleton
$replace TCorbaSkeleton
  // -- {InterfaceName} interface
  I{InterfaceName} = interface( I{iif|InterfaceParent|CorbaDispatch|Dispatch|{InterfaceParent}} )
    {guid}
{InterfaceMethods}
{InterfaceProperties}
  end;

  // -- {InterfaceName} Skeleton
  T{InterfaceName}Skeleton = class(T{InterfaceParent}Skeleton)
  private
    FIntf: I{InterfaceName};
  public
    constructor Create(const InstanceName: string; const Impl: IUnknown); override;
    procedure GetImplementation(out Impl: IUnknown); override; stdcall;
  published
{SkeletonMethods}
  end;

$END Interfaces_S

$MACRO Interfaces_C
$loop Interfaces
  // -- {InterfaceName} interface
  I{InterfaceName} = interface( I{iif|InterfaceParent|CorbaDispatch|Dispatch|{InterfaceParent}} )
    {guid}
{InterfaceMethods}
{InterfaceProperties}
  end;

  // -- {InterfaceName} Stub
  T{InterfaceName}Stub = class(T{InterfaceParent}Stub, I{InterfaceName})
  public
{InterfaceMethods}
  end;

$END Interfaces_C

$MACRO InterfaceMethods
$loop Methods
    {MethodType} {MethodName} {MethodParameters}{iif|MethodReturn|void||: }{MethodReturnPas};
$END InterfaceMethods

$MACRO InterfaceProperties
$loop Properties
    property {PropertyName}{PropertyIndex}: {PropertyReturnPas} read {PropertyGet}{iif|PropertySet||| write {PropertySet}};
$END InterfaceMethods

$MACRO MethodParameters
$loop Parameters
$nolf
$find )(
$replace ;
({ParameterMdf} {ParameterName}: {ParameterTypePas})
$END MethodParameters

$MACRO Stubs
$loop Interfaces
  T{InterfaceName}Stub = class(T{InterfaceParent}Stub, I{InterfaceName})
  public
  {InterfaceMethods}
  end;

$END Stubs

$MACRO Skeletons
$loop Interfaces
$find TCorbaDispatchSkeleton
$replace TCorbaSkeleton
  T{InterfaceName}Skeleton = class(T{InterfaceParent}Skeleton)
  private
    FIntf: I{InterfaceName};
  public
    constructor Create(const InstanceName: string; const Impl: IUnknown); override;
    procedure GetImplementation(out Impl: IUnknown); override; stdcall;
  published
  {SkeletonMethods}
  end;

$END Skeletons

$MACRO Factories
$loop Interfaces
  T{InterfaceName}CorbaFactory = class
    class function CreateInstance(const InstanceName: string): I{InterfaceName};
  end;

$END Skeletons

$MACRO SkeletonMethods
$loop Methods
    procedure {MethodName} (const InBuf: IMarshalInBuffer; Cookie: Pointer);
$END Skeleton Methodds

$MACRO IntToPrincipal
function IntToPrincipal(code: integer): TCorbaPrincipal;
var
  p2: array [0..1] of byte;
begin
  //p2[0] := code;
  p2[0] := code mod 256;
  p2[1] := code shr 8;
  result := MakePrincipal( p2 );
end;
$END IntToPrincipal

$MACRO StubImpls
$loop Interfaces
{StubMethodImpls}
$END StubImpls

$MACRO StubMethodImpls
$loop Methods
{MethodType} T{InterfaceName}Stub.{MethodName}{MethodParameters}{iif|MethodReturn|void||: }{MethodReturnPas};
var
  OutBuf: IMarshalOutBuffer;
  InBuf: IMarshalInBuffer;
  error: string;
begin
  {CodeSite}  CodeSiteEnterMethod( '{INterfaceName}.{MethodName}' );{CodeSiteEnd}
  FStub.CreateRequest('{MethodName}', True, OutBuf);
  {MarshalStub}
  FStub.Invoke(OutBuf, InBuf);
  error := UnmarshalWideText(InBuf);
  if length(error)>0 then raise EBowException.Create( error );
  {UnmarshalStub}
  {iif|{InterfaceName}.{MethodName}|ObjMediator.Init|SetPrincipal(IntToPrincipal(Result));|//}
  {iif|{InterfaceName}.{MethodName}|Global.Init|SetPrincipal(IntToPrincipal(Result));|//}
//~  {iif|{InterfaceName}.{MethodName}|Globals.Init|SetPrincipal(IntToPrincipal(Result));|}
  {CodeSite}  CodeSiteExitMethod( '{InterfaceName}.{MethodName}' );{CodeSiteEnd}
end;
$END StubMethodImpls

$MACRO MethodParametersUnMarshal
$loop Parameters
{ParameterName} := {UnmarshalFunction}(InBuf);
$END MethodsParametersUnMarshal

$MACRO SkeletonImpls1
$loop Interfaces
constructor T{InterfaceName}Skeleton.Create(const InstanceName: string; const Impl: IUnknown);
begin
  inherited;
  if 'T{InterfaceName}Skeleton'=self.ClassName then
    inherited InitSkeleton('{InterfaceName}', InstanceName, 'IDL:'+instance+'/I{InterfaceName}:1.0', tmSingleThread, True);
  FIntf := Impl as I{InterfaceName};
end;

procedure T{InterfaceName}Skeleton.GetImplementation(out Impl: IUnknown);
begin
  Impl := FIntf;
end;

{SkeletonMethodImpl}
$END SkeletonImpls1

  {iif|{IsSecure|{InterfaceName}.{MethodName}}|Y|if GetAutorization( DecodePrincipal(self), '{InterfaceName}.{MethodName}') then|}
  OR
  {iif|{IsSecure|{InterfaceName}}|Y|if FIntf.CheckRight( DecodePrincipal(self), '{MethodName}' ) then|}
  ...
  {iif|{IsSecure|{InterfaceName}.{MethodName}}|Y|else|;}
  {iif|{IsSecure|{InterfaceName}.{MethodName}}|Y|  error := 'You do not have access right!';|}

$MACRO SkeletonMethodImpl
$loop Methods
procedure T{InterfaceName}Skeleton.{MethodName}(const InBuf: IMarshalInBuffer; Cookie: Pointer);
var
  OutBuf: IMarshalOutBuffer;
  {MethodParametersVar}
  {MethodResultVar}
  error: WideString;
begin
  {UnmarshalSkeleton}
  error := '';
  try
//    {iif|{InterfaceName}.{MethodName}|ObjMediator.Init|//|}{iif|{InterfaceName}.{MethodName}|Global.Init|//|}FIntf.SetUserId( longint(self) );
    theThreadInfoList.Associate( pointer(self) );

    {iif|MethodReturn|void||result := }FIntf.{MethodName}{MethodParametersBare}
  except on e:Exception do
    error := e.Message;
  end;
  FSkeleton.GetReplyBuffer(Cookie, OutBuf);
  OutBuf.PutWideText(PWideChar(Pointer(error)));
  {MarshalSkeleton}
end;

$END SkeletonMethodImpl

$MACRO MethodParametersVar
$loop Parameters
{ParameterName}: {ParameterTypePas};
$END MethodParametersVar

$MACRO MethodResultVar
{iif|MethodReturn|void||Result: {MethodReturnPas};}
$END MethodResultVar

$MACRO MethodParametersBare
$loop Parameters
$find )(
$replace ,
$nolf
({ParameterName})
$END MethodParametersBare

$MACRO FactoryImpls
$loop Interfaces
class function T{InterfaceName}CorbaFactory.CreateInstance(const InstanceName: string): I{InterfaceName};
begin
  Result := CorbaFactoryCreateStub('IDL:'+instance+'/{InterfaceName}Factory:1.0', '{InterfaceName}',
    InstanceName, '', I{InterfaceName}) as I{InterfaceName};
end;

$END FactoryImpls

$MACRO Registration_S
$loop Interfaces
  CorbaInterfaceIDManager.RegisterInterface(I{InterfaceName}, 'IDL:'+instance+'/I{InterfaceName}:1.0');
  CorbaSkeletonManager.RegisterSkeleton(I{InterfaceName}, T{InterfaceName}Skeleton);

$END Registration_S

$MACRO Registration_C
$loop Interfaces
  CorbaStubManager.RegisterStub(I{InterfaceName}, T{InterfaceName}Stub);
  CorbaInterfaceIDManager.RegisterInterface(I{InterfaceName}, 'IDL:'+instance+'/I{InterfaceName}:1.0');

$END Registration_S

$MACRO MakePut
$nolf
  {iif|%2|long|OutBuf.PutLong({%1});|
{iif|{%2}|double|OutBuf.PutDouble({%1});|
{iif|{%2}|wstring|OutBuf.PutWideText(PWideChar(Pointer({%1})));|
{iif|{%2}|boolean|MarshalWordBool(OutBuf,{%1});|
{iif|{TypeKind|%2}|interface|MarshalObject(OutBuf, {%2}, {%1});|
? unknown datatype {%2}
}}}}}
$END

$MACRO MarshalStub
$loop Parameters
  {iif|ParameterDir|in|{MakePut|ParameterName|ParameterType}|}{iif|ParameterDir|inout|{MakePut|ParameterName|ParameterType}|}
$END

$MACRO MarshalSkeleton
{MarshalSkeleton1}
{iif|MethodReturn|void||{MakePut|Result|MethodReturn}}
$END

$MACRO MarshalSkeleton1
$loop Parameters
{iif|ParameterDir|out|{MakePut|ParameterName|ParameterType}|}{iif|ParameterDir|inout|{MakePut|ParameterName|ParameterType}|}
$END

$MACRO MakeGet
$nolf
  {iif|%2|long|{%1} := InBuf.GetLong;|
{iif|%2|double|{%1} := InBuf.GetDouble;|
{iif|%2|wstring|{%1} := UnmarshalWideText(InBuf);|
{iif|%2|boolean|{%1} := UnmarshalWordBool(InBuf);|
{iif|{TypeKind|%2}|interface|{%1} := UnmarshalObject(InBuf, {%2}) as {%2};|
? unknown datatype {%2}
}}}}}
$END

$MACRO UnmarshalStub
{UnmarshalStub1}
{iif|MethodReturn|void||{MakeGet|Result|MethodReturn}}
$END

$MACRO UnmarshalStub1
$loop Parameters
{iif|ParameterDir|out|{MakeGet|ParameterName|ParameterType}|}{iif|ParameterDir|inout|{MakeGet|ParameterName|ParameterType}|}
$END

$MACRO UnmarshalSkeleton
$loop Parameters
{iif|ParameterDir|in|{MakeGet|ParameterName|ParameterType}|}{iif|ParameterDir|inout|{MakeGet|ParameterName|ParameterType}|}
$END

$MACRO MethodType
$nolf
{iif|MethodReturn|void|procedure|function}
$END

$MACRO PascalType
$nolf
{iif|%1|void||{iif|%1|long|integer|{iif|%1|wstring|WideString|{iif|%1|boolean|WordBool|%1}}}}
$END

$MACRO MethodReturnPas
$nolf
{PascalType|MethodReturn}
$END

$MACRO PropertyReturnPas
$nolf
{PascalType|PropertyReturn}
$END

$MACRO ParameterTypePas
$nolf
{PascalType|ParameterType}
$END

$MACRO ~TypeKind
$nolf
interface
$END

$MACRO TypeKind
$nolf
{iif|%1|long|int|
{iif|{substr|%1|1|1}|i|interface|simple}
}
$END

$MACRO Test
Module Name : {ModuleName}
{Test_I}
$END

$MACRO Test_I
$loop Interfaces
{Test_M}
$END
  Interface Name   : {InterfaceName}
            Parent : {InterfaceParent}
  {Test_Pr}

$MACRO Test_M
$loop Methods
{Test_Pa}
$END
    Method Name   : {MethodName}
           Return : {MethodReturn}

$MACRO Test_Pr
$loop Properties
    Property Name   : {PropertyName}
             Return : {PropertyReturn}
             Get    : {PropertyGet}
             Set    : {PropertySet}
             Index  : {PropertyIndex}
$END

$MACRO Test_Pa
$loop Parameters
                TypeKind(Parameter Type) = {TypeKind|ParameterType}
                Make put = {MakePut|ParameterName|ParameterType}
                Make get = {MakeGet|ParameterName|ParameterType}
$END
      Parameter Name : {ParameterName}
                Type : {ParameterType}
                Dir  : {ParameterDir}
                Mdf  : {ParameterMdf}
                TypeKind(Parameter Type) = {TypeKind|ParameterType}

