orbpas.pas

三层的通用架构

procedure UnRegisterUserException(Description: PExceptionDescription);

implementation

uses CorbCnst;

var
  OrbDll: THandle = 0;

type
  TInitOrbProc = procedure(Argc: Integer; const Argv: TArgv; out Orb: IORB); stdcall;
  TCorbaStringFreeProc = procedure(Str: PChar); stdcall;
  TCorbaWStringFreeProc = procedure(Str: PWideChar); stdcall;
  TCorbaDuplicateAnyProc = function(Any: PCorbaAny): PCorbaAny; stdcall;
  TCorbaReleaseAnyProc = procedure(Any: PCorbaAny); stdcall;
  TCorbaAnyTypeProc = procedure (Any: PCorbaAny; out TypeCode: ITypeCode); stdcall;
  TCreateSkeletonProc = procedure(InterfaceName: PChar;
    const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
    InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
    out Skeleton: ISkeleton); stdcall;
  TBindStubProc = procedure(RepositoryID, InstanceID, HostName: PChar; const Orb: IORB;
    RefCountServer: CorbaBoolean; out Stub: IStub); stdcall;
  TVariantToAnyProc = function(Value: PVariant): PCorbaAny; stdcall;
  TAnyToVariantProc = function(Value: PCorbaAny; OV: PVariant): WordBool; stdcall;
  TPascalClearVariantProc = procedure (var V: Variant); stdcall;
  TPascalChangeTypeProc = function (var Dest, Source: Variant; VTCode: Integer): WordBool; stdcall;
  TInitAnyCallbacks = procedure (pcv: TPascalClearVariantProc; pct: TPascalChangeTypeProc); stdcall;
  TCreateUserExceptionProc = function (copy: TCopyUserExceptionProc; throwobj: TThrowUserExceptionProc): PUserExceptionProxy; stdcall;
  TRegisterUserExceptionProc = function (Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription; stdcall;
  TUnRegisterUserExceptionProc = procedure (Description: PExceptionDescription); stdcall;

procedure PascalClearVariantImpl(var V: Variant); stdcall;
begin
  V := Unassigned;
end;

function PascalChangeTypeImpl(var Dest, Source: Variant; VTCode: Integer): WordBool; stdcall;
begin
  Result := True;
  try
    Dest := VarAsType(Source, VTCode);
  except
    Result := False;
  end;
end;

var
  InitOrbProc: TInitOrbProc;
  CorbaStringFreeProc: TCorbaStringFreeProc;
  CorbaWStringFreeProc: TCorbaWStringFreeProc;
  CorbaReleaseAnyProc: TCorbaReleaseAnyProc;
  CorbaAnyTypeProc: TCorbaAnyTypeProc;
  CorbaDuplicateAnyProc: TCorbaDuplicateAnyProc;
  CreateSkeletonProc: TCreateSkeletonProc;
  BindStubProc: TBindStubProc;
  VariantToAnyProc: TVariantToAnyProc;
  AnyToVariantProc: TAnyToVariantProc;
  SequenceToVariantProc: TAnyToVariantProc;
  CreateUserExceptionProc: TCreateUserExceptionProc;
  RegisterUserExceptionProc: TRegisterUserExceptionProc;
  UnRegisterUserExceptionProc: TUnRegisterUserExceptionProc;

procedure LoadOrbProcs;
const
  orbpas = 'orbpas60.dll';
var
  InitAnyCallbacks: TInitAnyCallbacks;
begin
  if OrbDll > HINSTANCE_ERROR then Exit;
  OrbDll := LoadLibrary(PChar(orbpas));
  if OrbDll <= HINSTANCE_ERROR then
    raise Exception.CreateFmt('%s: %s', [SysErrorMessage(GetLastError), orbpas]);
  @InitORBProc := GetProcAddress(OrbDll, 'ORB_init');
  @CorbaStringFreeProc := GetProcAddress(OrbDll, 'String_Free');
  @CorbaWStringFreeProc := GetProcAddress(OrbDll, 'WString_Free');
  @CorbaDuplicateAnyProc := GetProcAddress(OrbDll, 'DuplicateAny');
  @CorbaReleaseAnyProc := GetProcAddress(OrbDll, 'ReleaseAny');
  @CorbaAnyTypeProc := GetProcAddress(OrbDll, 'AnyType');
  @CreateSkeletonProc := GetProcAddress(OrbDll, 'DelphiServant_Create');
  @BindStubProc := GetProcAddress(OrbDll, 'DelphiStub_Bind');
  @VariantToAnyProc := GetProcAddress(OrbDll, 'VariantToAny');
  @AnyToVariantProc := GetProcAddress(OrbDll, 'Any2Variant');
  @SequenceToVariantProc := GetProcAddress(OrbDll, 'Sequence2Variant');
  @InitAnyCallbacks := GetProcAddress(OrbDll, 'InitAnyCallbacks');
  if Assigned(InitAnyCallbacks) then
    InitAnyCallbacks(PascalClearVariantImpl, PascalChangeTypeImpl);
  @CreateUserExceptionProc := GetProcAddress(OrbDll, 'CreateDelphiException');
  @RegisterUserExceptionProc := GetProcAddress(OrbDll, 'RegisterDelphiException');
  @UnRegisterUserExceptionProc := GetProcAddress(OrbDll, 'UnRegisterDelphiException');
end;

procedure ValidateProc(var Proc);
begin
  if Pointer(Proc) = nil then raise Exception.CreateRes(@sCorbaNotInitialized);
end;

procedure InitORB(const Argv: TArgv; out Orb: IORB);
begin
  LoadOrbProcs;
  ValidateProc(InitORBProc);
  InitORBProc(Length(Argv), Argv, Orb);
end;

procedure CorbaStringFree(Str: PChar);
begin
  ValidateProc(CorbaStringFreeProc);
  CorbaStringFreeProc(Str);
end;

procedure CorbaWStringFree(Str: PWideChar);
begin
  ValidateProc(CorbaWStringFreeProc);
  CorbaWStringFreeProc(Str);
end;

function CorbaDuplicateAny(Any: PCorbaAny): PCorbaAny;
begin
  ValidateProc(CorbaDuplicateAnyProc);
  Result := CorbaDuplicateAnyProc(Any);
end;

procedure CorbaReleaseAny(Any: PCorbaAny);
begin
  ValidateProc(CorbaReleaseAnyProc);
  CorbaReleaseAnyProc(Any);
end;

procedure CorbaAnyType(Any: PCorbaAny; out TypeCode: ITypeCode);
begin
  ValidateProc(CorbaAnyTypeProc);
  CorbaAnyTypeProc(Any, TypeCode);
end;

procedure CreateSkeleton(InterfaceName: PChar;
  const DelphiObject: ISkeletonObject; Serialize: CorbaBoolean;
  InstanceName, RepositoryID: PChar; ClientRefCount: CorbaBoolean;
  out Skeleton: ISkeleton);
begin
  ValidateProc(CreateSkeletonProc);
  CreateSkeletonProc(InterfaceName, DelphiObject, Serialize, InstanceName,
    RepositoryID, ClientRefCount, Skeleton);
end;

procedure BindStub(RepositoryID, InstanceName, HostName: PChar; const Orb: IORB;
  RefCountServer: CorbaBoolean; out Stub: IStub);
begin
  ValidateProc(BindStubProc);
  BindStubProc(RepositoryID, InstanceName, HostName, Orb, RefCountServer, Stub);
end;

function VariantToAny(Value: PVariant): PCorbaAny;
begin
  ValidateProc(VariantToAnyProc);
  Result := VariantToAnyProc(Value);
end;

function AnyToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
begin
  ValidateProc(AnyToVariantProc);
  Result := AnyToVariantProc(Value, OV);
end;

function SequenceToVariant(Value: PCorbaAny; OV: PVariant): Boolean;
begin
  ValidateProc(SequenceToVariantProc);
  Result := SequenceToVariantProc(Value, OV);
end;

function CreateUserException(copy: TCopyUserExceptionProc; throwobj: TThrowUserExceptionProc): PUserExceptionProxy;
begin
  ValidateProc(CreateUserExceptionProc);
  Result := CreateUserExceptionProc(copy, throwobj);
end;

function RegisterUserException(Name, RepositoryID: PChar; Factory: TUserExceptionFactoryProc): PExceptionDescription;
begin
  ValidateProc(RegisterUserExceptionProc);
  Result := RegisterUserExceptionProc(Name, RepositoryID, Factory);
end;

procedure UnRegisterUserException(Description: PExceptionDescription);
begin
  ValidateProc(UnRegisterUserExceptionProc);
  UnRegisterUserExceptionProc(Description);
end;

initialization

finalization
  // jmt.  Do not unload because threads created by orb_br.dll
  // may be active. 
  // if OrbDll > HINSTANCE_ERROR then FreeLibrary(OrbDll);

end.