corbaobj.pas

三层的通用架构

{ *********************************************************************** }
{                                                                         }
{ Delphi Runtime Library                                                  }
{                                                                         }
{ Copyright (c) 1999-2001 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit CorbaObj;

{$T-,H+,X+}

interface

uses Variants, SysUtils, OrbPas, ActiveX;

type
  CorbaBoolean = ORBPAS.CorbaBoolean;
  CorbaULong = ORBPAS.CorbaULong;
  IObject = System.IUnknown;
  TCorbaPrincipal = array of Byte;
  TCommandLine = ORBPAS.TArgv;
  TCKind = ORBPAS.TCKind;
  TAny = Variant;
  ITypeCode = ORBPAS.ITypeCode;
  
  ICorbaObject = interface
    ['{0BAF8E01-CE38-11D1-AADC-00C04FB17A72}']
    function NonExistent: Boolean;
    function Hash(Maximum: Integer): Integer;
    function IsA(const LogicalTypeId: string): Boolean;
    procedure SetPrincipal(const Prinicpal: TCorbaPrincipal);
  end;

  ECorbaException = class(Exception)
  protected
    function GetMessage: string;
  public
    property Name: string read GetMessage;
  end;

  ECorbaDispatch = class(Exception);

  ECorbaUserException = class(ECorbaException)
  private
   FProxy: PUserExceptionProxy;
  public
    constructor Create(const Name: string);
    procedure Copy(const InBuf: IMarshalInBuffer); virtual; abstract;
    procedure Throw;
    property Proxy: PUserExceptionProxy read FProxy;
  end;

  TCorbaThreadModel = (tmMultiThreaded, tmSingleThread);

  TCorbaInstancing = (iSingleInstance, iMultiInstance);

{$M+}
  TCorbaSkeleton = class(TInterfacedObject, ISkeletonObject)
  protected
    FSkeleton: ISkeleton;
    procedure InitSkeleton(const InterfaceName, InstanceName, RepositoryID: string;
      ThreadModel: TCorbaThreadModel; ClientRefCount: Boolean);
  protected
    { ISkeletonObject }
    procedure GetSkeleton(out Skeleton: ISkeleton); stdcall;
    procedure GetImplementation(out Impl: IObject); virtual; stdcall;
    function Execute(Operation: PChar; const Strm: IMarshalInBuffer;
      Cookie: Pointer): CorbaBoolean; stdcall;
  public
    constructor Create(const InstanceName: string; const Impl: IObject); virtual;
    destructor Destroy; override;
  end;
{$M-}

  TCorbaStub = class(TInterfacedObject, IStubObject, ICorbaObject)
  protected
    FStub: IStub;
  protected
    { IStubObject }
    procedure GetStub(out Stub: IStub); stdcall;
    { ICorbaObject }
    function NonExistent: Boolean;
    function Hash(Maximum: Integer): Integer;
    function IsA(const LogicalTypeId: string): Boolean;
    procedure SetPrincipal(const Prinicpal: TCorbaPrincipal);
  public
    constructor Create(const Stub: IStub); virtual;
    destructor Destroy; override;
  end;

  TCorbaDispatchStub = class(TCorbaStub, IDispatch)
  protected
    { IDispatch }
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
  end;

  TCorbaListManager = class
  private
    FSync: TMultiReadExclusiveWriteSynchronizer;
  protected
    procedure BeginRead;
    procedure BeginWrite;
    procedure EndRead;
    procedure EndWrite;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TInterfaceIDEntryDesc = record
    RepositoryID: string;
    IID: TGUID;
  end;
  TInterfaceIDList = array of TInterfaceIDEntryDesc;

  TCorbaInterfaceIDManager = class(TCorbaListManager)
  private
    FList: TInterfaceIDList;
    FUsed: Integer;
  public
    procedure RegisterInterface( const IID: TGUID; const RepositoryID: string);
    function SearchGUID(const RepositoryID: string; out IID: TGUID): Boolean;
    function SearchID(const IID: TGUID; out RepositoryID: string): Boolean;
    function FindGUID(const RepositoryID: string): TGUID;
    function FindID(const IID: TGUID): string;
  end;

  TCorbaSkeletonClass = class of TCorbaSkeleton;

  TSkeletonEntryDesc = record
    IID: TGUID;
    SkeletonClass: TCorbaSkeletonClass;
  end;
  TSkeletonList = array of TSkeletonEntryDesc;

  TCorbaSkeletonManager = class(TCorbaListManager)
  private
    FList: TSkeletonList;
    FUsed: Integer;
  public
    procedure RegisterSkeleton(IID: TGUID; Skeleton: TCorbaSkeletonClass);
    function CreateSkeleton(IID: TGUID; const InstanceName: string;
      const Impl: IObject): ISkeletonObject;
  end;

  TCorbaStubClass = class of TCorbaStub;

  TStubEntryDesc = record
    IID: TGUID;
    StubClass: TCorbaStubClass;
  end;
  TStubList = array of TStubEntryDesc;

  TCorbaStubManager = class(TCorbaListManager)
  private
    FList: TStubList;
    FUsed: Integer;
  public
    procedure RegisterStub(IID: TGUID; Stub: TCorbaStubClass);
    function CreateStub(IID: TGUID; const Stub: IStub): IObject;
  end;

  TCorbaFactory = class;

  TCorbaImplementation = class(TObject, IUnknown)
  protected
    FRefCount: Integer;
    FController: Pointer;
    FFactory: TCorbaFactory;
    { IUnknown }
    function IUnknown.QueryInterface = ObjQueryInterface;
    function IUnknown._AddRef = ObjAddRef;
    function IUnknown._Release = ObjRelease;
    function ObjAddRef: Integer; virtual; stdcall;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
    function ObjRelease: Integer; virtual; stdcall;
    { IUnknown methods for other interfaces }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { Stub implementation for IDispatch }
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create(Controller: IObject; AFactory: TCorbaFactory); virtual;
  end;

  TCorbaImplementationClass = class of TCorbaImplementation;

  TCorbaFactory = class(TInterfacedObject, ISkeletonObject)
  private
    FInterfaceName: string;
    FInstanceName: string;
    FRepositoryID: string;
    FInstancing: TCorbaInstancing;
    FThreadModel: TCorbaThreadModel;
    FIID: TGUID;
    FSkeleton: ISkeleton;
    FSingleInstanceSkelton: ISkeletonObject;
    FTypeInfo: ITypeInfo;
  protected
    { ISkeletonObject }
    procedure GetSkeleton(out Skeleton: ISkeleton); stdcall;
    procedure GetImplementation(out Impl: IObject); stdcall;
    function Execute(Operation: PChar; const Strm: IMarshalInBuffer;
      Cookie: Pointer): CorbaBoolean; stdcall;
    function GetTypeInfo(out TypeInfo): HRESULT;
  protected
    function CreateInstance(const InstanceName: string): ISkeletonObject; virtual;
    function CreateInterface(const InstanceName: string): IObject; virtual;
    procedure RegisterFactory;
  public
    constructor Create(const InterfaceName, InstanceName, RepositoryId: string;
      const ImplGUID: TGUID; Instancing: TCorbaInstancing = iMultiInstance;
      ThreadModel: TCorbaThreadModel = tmSingleThread);
    destructor Destroy; override;
    property InterfaceName: string read FInterfaceName;
    property InstanceName: string read FInstanceName;
    property RepositoryID: string read FRepositoryID;
    property Instancing: TCorbaInstancing read FInstancing;
    property ThreadModel: TCorbaThreadModel read FThreadModel;
  end;

  TCorbaObjectFactory = class(TCorbaFactory)
  private
    FImplementationClass: TCorbaImplementationClass;
  protected
    function CreateInterface(const InstanceName: string): IObject; override;
  public
    constructor Create(const InterfaceName, InstanceName, RepositoryId: string;
      const ImplGUID: TGUID; ImplementationClass: TCorbaImplementationClass;
      Instancing: TCorbaInstancing = iMultiInstance;
      ThreadModel: TCorbaThreadModel = tmSingleThread);
    property ImplementationClass: TCorbaImplementationClass read FImplementationClass;
  end;

  TFactoryList = array of TCorbaFactory;

  TCorbaFactoryManager = class(TCorbaListManager)
  private
    FList: TFactoryList;
    FUsed: Integer;
    FRegistered: Boolean;
  public
    destructor Destroy; override;
    procedure AddFactory(Factory: TCorbaFactory);
    procedure RegisterFactories;
    function Find(const RepositoryID, InterfaceName, InstanceName: string): TCorbaFactory;
  end;

  TBOA = class
  private
    BOA: IBOA;
  public
    class procedure Initialize(const CommandLine: TCommandLine);
    procedure ObjIsReady(const Obj: IObject);
    procedure ImplIsReady;
    procedure Deactivate(const Obj: IObject);
    function GetPrincipal(const Obj: IObject): TCorbaPrincipal;
  end;

  TORB = class
  private
    ORB: IORB;
    function MakeComplexAny(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
  public
    class procedure Initialize; overload;
    class procedure Initialize(const CommandLine: TCommandLine); overload;
    function StringToObject(const ObjectString: string): IObject;
    function ObjectToString(const Obj: IObject): string;
    procedure Shutdown;

    { Binding methods }
    function Bind(const RepositoryID: string; const ObjectName: string = '';
      const HostName: string = ''): IObject; overload;
    function Bind(const InterfaceID: TGUID; const ObjectName: string = '';
      const HostName: string = ''): IObject; overload;

    { Dynamic invocation methods }
    function FindTypeCode(const RepositoryID: string): ITypeCode;
    function MakeArray(Kind: TCKind; const Elements: array of TAny): TAny; overload;
    function MakeArray(TypeCode: ITypeCode; const Elements: array of TAny): TAny; overload;
    function MakeSequence(Kind: TCKind; const Elements: array of TAny): TAny; overload;
    function MakeSequence(TypeCode: ITypeCode; const Elements: array of TAny): TAny; overload;
    function MakeStructure(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
    function MakeAlias(const RepositoryID, TypeName: string; Value, Test: TAny): TAny;

    function MakeTypeCode(Kind: TCKind): ITypeCode;
    function MakeSequenceTypeCode(Bound: CorbaULong; const TC: ITypeCode): ITypeCode;
    function MakeStructureTypeCode(const RepositoryID, Name: string; Members: TStructMembers): ITypeCode;
    function MakeAliasTypeCode(const RepositoryID, Name: string; const TC: ITypeCode): ITypeCode;
    function MakeObjectRefTypeCode(const RepositoryID, Name: string): ITypeCode;
  end;

{ CORBA helper routines }

procedure CorbaInitialize;
function CorbaBind(const RepositoryID: string; const ObjectName: string = '';
  const HostName: string = ''): IObject; overload;
function CorbaBind(const InterfaceID: TGUID; const ObjectName: string = '';
  const HostName: string = ''): IObject; overload;
function MakePrincipal(const Bytes: array of Byte): TCorbaPrincipal;
function BOA: TBOA;
function ORB: TORB;

{ Any helpers }

function VariantArrayToSequence(TypeCode: ITypeCode; const VariantArray: Variant): TAny;
function SequenceToVariantArray(Sequence: TAny): Variant;
function AnyToObject(Any: TAny; IID: TGUID): IObject;

{ Global variables }

var
  CorbaSkeletonManager: TCorbaSkeletonManager;
  CorbaStubManager: TCorbaStubManager;
  CorbaInterfaceIDManager: TCorbaInterfaceIDManager;

{ Internal marshalling routines }

procedure MarshalObject(const OutBuf: IMarshalOutBuffer; IID: TGUID;
  const Intf: IObject);
function UnmarshalObject(const InBuf: IMarshalInBuffer; IID: TGUID): IObject;
procedure MarshalAny(const OutBuf: IMarshalOutBuffer; const OV: Variant);
function UnmarshalAny(const InBuf: IMarshalInBuffer): Variant;
function UnmarshalText(const InBuf: IMarshalInBuffer): string;
function UnmarshalWideText(const InBuf: IMarshalInBuffer): WideString;
procedure MarshalWordBool(const OutBuf: IMarshalOutBuffer; Value: WordBool);
function UnmarshalWordBool(const InBuf: IMarshalInBuffer): WordBool;
function CorbaFactoryCreateStub(const RepId, FactoryId, InstanceName, HostName: string;
  IID: TGUID): IObject;

implementation

uses Windows, CorbCnst;

var
  CorbaFactoryManager: TCorbaFactoryManager;
  BOAVar: TBOA;
  ORBVar: TORB;

type
  TUnmarshalProc =  procedure (const Strm: IMarshalInBuffer; Cookie: Pointer) of object;

{ ECorbaException }

function ECorbaException.GetMessage: string;
begin
  Result := Message;
end;

{ ECorbaUserException }

constructor ECorbaUserException.Create(const Name: string);
begin
  inherited Create(Name);
  FProxy := CreateUserException(Copy, Throw);
end;

procedure ECorbaUserException.Throw;
begin
  raise Self;
end;

{ TCorbaSkeleton }

constructor TCorbaSkeleton.Create(const InstanceName: string;
  const Impl: IObject);
begin
  inherited Create;
end;

destructor TCorbaSkeleton.Destroy;
begin
  FSkeleton := nil;
  inherited Destroy;
end;

procedure TCorbaSkeleton.InitSkeleton(const InterfaceName, InstanceName,
  RepositoryID: string; ThreadModel: TCorbaThreadModel; ClientRefCount: Boolean);
var
  Factory: TCorbaFactory;
  Serialize: Boolean;
begin
  Factory := CorbaFactoryManager.Find(RepositoryID, InterfaceName, InstanceName);
  if Factory <> nil then
    Serialize := Factory.ThreadModel = tmSingleThread
  else
    Serialize := ThreadModel = tmSingleThread;
  CreateSkeleton(PChar(Pointer(InterfaceName)), Self, Serialize,
    PChar(Pointer(InstanceName)),  PChar(Pointer(RepositoryID)),
      ClientRefCount, FSkeleton);
end;

procedure TCorbaSkeleton.GetSkeleton(out Skeleton: ISkeleton);
begin
  Skeleton := FSkeleton;
end;

procedure TCorbaSkeleton.GetImplementation(out Impl: IObject);
begin
  Impl := nil;
end;

function TCorbaSkeleton.Execute(Operation: PChar; const Strm: IMarshalInBuffer;
 Cookie: Pointer): CorbaBoolean;
var
  M: TUnmarshalProc;
begin
  Result := False;
  try
    TMethod(M).Code := Self.MethodAddress(Operation);
    if TMethod(M).Code = nil then Exit;
    TMethod(M).Data := Self;
    M(Strm, Cookie);
  except
    Exit;
  end;
  Result := True;
end;

{ TCorbaStub }

constructor TCorbaStub.Create(const Stub: IStub);
begin
  inherited Create;
  FStub := Stub;
end;

destructor TCorbaStub.Destroy;
begin
  try
    FStub := nil;
  except
    // Ignore exceptions when disconnecting
  end;
  inherited Destroy;
end;

procedure TCorbaStub.GetStub(out Stub :IStub); stdcall;
begin
  Stub := FStub;
end;

function TCorbaStub.Hash(Maximum: Integer): Integer;
begin
  Result := Integer(FStub.Hash(CorbaULong(Maximum)));
end;

function TCorbaStub.IsA(const LogicalTypeId: string): Boolean;
begin
  Result := FStub.IsA(Pointer(LogicalTypeId));
end;

function TCorbaStub.NonExistent: Boolean;
begin
  Result := FStub.NonExistent;
end;

procedure TCorbaStub.SetPrincipal(const Prinicpal: TCorbaPrincipal);
begin
  FStub.SetPrincipal(@Prinicpal[0], High(Prinicpal) + 1);
end;

{ TCorbaDispatchStub }

const
  E_NOTIMPL = HResult($80004001);

function TCorbaDispatchStub.GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TCorbaDispatchStub.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TCorbaDispatchStub.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TCorbaDispatchStub.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TCorbaListManager }

constructor TCorbaListManager.Create;
begin
  FSync := TMultiReadExclusiveWriteSynchronizer.Create;
end;

destructor TCorbaListManager.Destroy;
begin
  FSync.Free;
end;

procedure TCorbaListManager.BeginRead;
begin
  FSync.BeginRead;
end;

procedure TCorbaListManager.BeginWrite;
begin
  FSync.BeginWrite;
end;

procedure TCorbaListManager.EndRead;
begin
  FSync.EndRead;
end;

procedure TCorbaListManager.EndWrite;
begin
  FSync.EndWrite;
end;