orbpas.pas

三层的通用架构

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

unit OrbPas;

interface

uses Windows, ActiveX, Variants, SysUtils;

type
  ICorbaObj = interface;
  IMarshalInBuffer = interface;
  IMarshalOutBuffer = interface;
  ISkeleton = interface;
  IStub = interface;
  IBOA = interface;
  IORB = interface;
  ISkeletonObject = interface;
  IStubObject = interface;

  CorbaBoolean = ByteBool;
  CorbaULong = Integer;
  PCorbaAny = type Pointer;
  PCorbaObject = type Pointer;
  PCorbaOrb = type Pointer;
  PCorbaInterfaceDef = type Pointer;
  PMarshalInbuffer = type Pointer;
  PMarshalOutbuffer = type Pointer;
  PUserExceptionProxy = type Pointer;
  PExceptionDescription = type Pointer;

  TArgv = array of string;

  ICorbaObj = interface
    ['{47E946E1-BEA1-11D1-AA8A-00C04FB16F42}']
    function CorbaObject: PCorbaObject; stdcall;
    function IsLocal: CorbaBoolean; stdcall;
  end;

  IMarshalInBuffer = interface
    ['{47E946E2-BEA1-11D1-AA8A-00C04FB16F42}']
    function Buffer: PMarshalInbuffer; stdcall;
    function GetText: PChar; stdcall;
    function GetChar: Shortint; stdcall;
    function GetUnsignedChar: Byte; stdcall;
    function GetShort: Smallint; stdcall;
    function GetUnsignedShort: Word; stdcall;
    function GetLong: Integer; stdcall;
    function GetUnsignedLong: UINT; stdcall;
    function GetFloat: Single; stdcall;
    function GetDouble: Double; stdcall;
    function GetWideText: PWideChar; stdcall;
    function GetWidechar: Word; stdcall;
    function GetAny: PCorbaAny; stdcall;
    procedure GetObject(out Obj: ICorbaObj; ref_cnt: CorbaBoolean = True); stdcall;
  end;

  IMarshalOutBuffer = interface
    ['{47E946E3-BEA1-11D1-AA8A-00C04FB16F42}']
    function Buffer: PMarshalOutbuffer; stdcall;
    procedure PutText(Value: PChar); stdcall;
    procedure PutChar(Value: Shortint); stdcall;
    procedure PutUnsignedChar(Value: Byte); stdcall;
    procedure PutShort(Value: Smallint); stdcall;
    procedure PutUnsignedShort(Value: Word); stdcall;
    procedure PutLong(Value: Integer); stdcall;
    procedure PutUnsignedLong(Value: UINT); stdcall;
    procedure PutFloat(Value: Single); stdcall;
    procedure PutDouble(Value: Double); stdcall;
    procedure PutWideText(Value: PWideChar); stdcall;
    procedure PutWidechar(Value: Word); stdcall;
    procedure PutAny(Value: PCorbaAny); stdcall;
    procedure PutObject(const Value: ICorbaObj); stdcall;
  end;

  ISkeleton = interface(ICorbaObj)
    ['{47E946E4-BEA1-11D1-AA8A-00C04FB16F42}']
    procedure GetImplementation(out Impl: IUnknown); stdcall;
    procedure GetReplyBuffer(cookie: Pointer; out Outbuf: IMarshalOutBuffer); stdcall;
  end;

  IStub = interface(ICorbaObj)
    ['{47E946E5-BEA1-11D1-AA8A-00C04FB16F42}']
    procedure CreateRequest(Operation: PChar; ResponseExpected: CorbaBoolean; out Outbuf: IMarshalOutBuffer); stdcall;
    procedure Invoke(const Outbuf: IMarshalOutBuffer; out Inbuf: IMarshalInBuffer); stdcall;
    function GetInterface: PCorbaInterfaceDef; stdcall;
    function NonExistent: CorbaBoolean; stdcall;
    function Hash(Maximum: CorbaULong): CorbaULong; stdcall;
    function IsA(LogicalTypeId: PChar): CorbaBoolean; stdcall;
    procedure SetPrincipal(Bytes: Pointer; Length: CorbaULong); stdcall;
    function RepositoryID: PChar; stdcall;
    function Dispatch(CallDesc: PCallDesc; Params: Pointer; out Result: Variant): Integer; stdcall;
  end;

  TCKind = (tk_null, tk_void, tk_short, tk_long, tk_ushort, tk_ulong, tk_float,
    tk_double, tk_boolean, tk_char, tk_octet, tk_any, tk_TypeCode, tk_Principal,
    tk_objref, tk_struct, tk_union, tk_enum, tk_string, tk_sequence, tk_array,
    tk_alias, tk_except, tk_longlong, tk_ulonglong, tk_longdouble, tk_wchar,
    tk_wstring, tk_fixed);

  ITypeCode = interface
    ['{D3D381F7-D944-11D1-AAEC-00C04FB17A72}']
    function Kind: TCKind; stdcall;
    procedure ContentType(out tc: ITypeCode); stdcall;
    function DefaultIndex: Integer; stdcall;
    procedure DiscriminatorType(out tc: ITypeCode); stdcall;
    function Equal(const tc: ITypeCode): CorbaBoolean; stdcall;
    function Id: PChar; stdcall;
    function Length: CorbaULong; stdcall;
    function MemberCount: CorbaULong; stdcall;
    function MemberLabel(index: CorbaULong): PCorbaAny; stdcall;
    function MemberName(index: CorbaULong): PChar; stdcall;
    procedure MemberType(index: CorbaULong; out tc: ITypeCode); stdcall;
    function Name: PChar; stdcall;
    function Parameter(index: Integer): PCorbaAny; stdcall;
    function ParameterCount: Integer; stdcall;
  end;

  IBOA = interface
    ['{47E946E6-BEA1-11D1-AA8A-00C04FB16F42}']
    procedure ObjIsReady(const Skeleton: ISkeleton); stdcall;
    procedure ImplIsReady; stdcall;
    procedure Deactivate(const Skeleton: ISkeleton); stdcall;
    function GetPrincipalLength(Skeleton: ISkeleton): Integer; stdcall;
    function GetPrincipal(Skeleton: ISkeleton; Bytes: Pointer): Integer; stdcall;
  end;

  TStructMember = record
    Name: string;
    TC: ITypeCode;
  end;

  TStructMembers = array of TStructMember;

  IORB = interface
    ['{47E946E7-BEA1-11D1-AA8A-00C04FB16F42}']
    function Orb: PCorbaOrb stdcall;
    procedure BOAInit(Argc: Integer; const Argv: TArgv; out BOA: IBOA); stdcall;
    function ObjectToString(const Obj: IStub): PChar; stdcall;
    procedure StringToObject(Str: PChar; out Obj: IStub); stdcall;
    procedure Shutdown; stdcall;
    procedure FindRepositoryTC(RepID: PChar; out TC: ITypeCode); stdcall;
    procedure CreateTC(Kind: TCKind; out TC: ITypeCode); stdcall;
    procedure CreateArrayTC(Bound: CorbaULong; const TC: ITypeCode;
      out Result: ITypeCode); stdcall;
    procedure CreateSequenceTC(Bound: CorbaULong; const TC: ITypeCode;
      out Result: ITypeCode); stdcall;
    function MakeAny(const TC: ITypeCode; VS: array of Variant): PCorbaAny; stdcall;
    function DispatchStruct(Any: PCorbaAny; CallDesc: PCallDesc; Params: Pointer;
      out Result: Variant): Integer; stdcall;
    procedure CreateAliasTC(RepID: PChar; TypeName: PChar; const TC: ITypeCode; out Result: ITypeCode); stdcall;
    procedure CreateStructTC(Kind: TCKind; RepId, Name: PChar; Members: TStructMembers; nMember: Integer; out Result: ITypeCode); stdcall;
    procedure CreateObjRefTC(RepId, Name: PChar; out Result: ITypeCode); stdcall;
  end;

  ISkeletonObject = interface
    ['{47E946E8-BEA1-11D1-AA8A-00C04FB16F42}']
    procedure GetSkeleton(out Skeleton: ISkeleton); stdcall;
    procedure GetImplementation(out Impl: IUnknown); stdcall;
    function Execute(Operation: PChar; const Strm: IMarshalInBuffer;
      Cookie: Pointer): CorbaBoolean; stdcall;
  end;

  IStubObject = interface
    ['{47E946E9-BEA1-11D1-AA8A-00C04FB16F42}']
    procedure GetStub(out stub :IStub); stdcall;
  end;

type
  TCopyUserExceptionProc = procedure (const InBuf: IMarshalInBuffer) of object; register;
  TThrowUserExceptionProc = procedure of object; register;
  TUserExceptionFactoryProc = function : PUserExceptionProxy; cdecl;

procedure InitORB(const Argv: TArgv; out Orb: IORB);
procedure CorbaStringFree(Str: PChar);
procedure CorbaWStringFree(Str: PWideChar);
function CorbaDuplicateAny(Any: PCorbaAny): PCorbaAny;
procedure CorbaReleaseAny(Any: PCorbaAny);
procedure CorbaAnyType(Any: PCorbaAny; out TypeCode: ITypeCode);
procedure CreateSkeleton(InterfaceName: PChar;
  const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
  InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
  out Skeleton: ISkeleton);
procedure BindStub(RepositoryID, InstanceName, HostName: PChar; const Orb: IORB;
  RefCountServer: CorbaBoolean; out Stub: IStub);
function VariantToAny(Value: PVariant): PCorbaAny;
function AnyToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
function SequenceToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
function CreateUserException(copy: TCopyUserExceptionProc; throwobj: TThrowUserExceptionProc): PUserExceptionProxy;
function RegisterUserException(Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription;