corbaobj.pas

三层的通用架构

  if Stub = nil then
    Result := nil
  else
  begin
    ID := Stub.RepositoryID;
    try
      Result := CorbaStubManager.CreateStub(CorbaInterfaceIDManager.FindGUID(ID), Stub);
    finally
      CorbaStringFree(ID);
    end;
  end;
end;

procedure TORB.Shutdown;
begin
  ORB.Shutdown;
end;

{ Dynamic invocation helper methods }

function TORB.FindTypeCode(const RepositoryID: string): ITypeCode;
begin
  ORB.FindRepositoryTC(PChar(RepositoryID), Result);
end;

function TORB.MakeArray(Kind: TCKind; const Elements: array of TAny): TAny;
var
  TC: ITypeCode;
begin
  ORB.CreateTC(Kind, TC);
  Result := MakeArray(TC, Elements);
end;

function TORB.MakeArray(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
begin
  Result := MakeComplexAny(TypeCode, Elements);
end;

function TORB.MakeSequence(Kind: TCKind; const Elements: array of TAny): TAny;
var
  TC: ITypeCode;
begin
  ORB.CreateTC(Kind, TC);
  Result := MakeSequence(TC, Elements);
end;

function TORB.MakeSequence(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
begin
  Result := MakeComplexAny(TypeCode, Elements);
end;

const
  reVarNotArray       = 19;

function GetVarArray(const A: Variant): PSafeArray;
begin
  if TVarData(A).VType and varArray = 0 then RunError(reVarNotArray);
  if TVarData(A).VType and varByRef <> 0 then
    Result := PSafeArray(TVarData(A).VPointer^) else
    Result := PSafeArray(TVarData(A).VArray);
end;

function TORB.MakeStructure(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
begin
  Result := MakeComplexAny(TypeCode, Elements);
end;

function TORB.MakeAlias(const RepositoryID, TypeName: string; Value, Test: TAny): TAny;
var
  Temp: Variant;
  TC, TC2: ITypeCode;
begin
  TVarData(Temp).VAny := CorbaDuplicateAny(VariantToAny(@Value));
  TVarData(Temp).VType := varAny;
  CorbaAnyType(TVarData(Temp).VAny, TC);
  ORB.CreateAliasTC(PChar(Pointer(RepositoryID)), PChar(Pointer(TypeName)),
    TC, TC2);
  TVarData(Result).VAny := ORB.MakeAny(TC2, [Temp]);
  TVarData(Result).VType := varAny;
end;

function TORB.MakeTypeCode(Kind: TCKind): ITypeCode;
begin
  ORB.CreateTC(Kind, Result);
end;

function TORB.MakeSequenceTypeCode(Bound: CorbaULong; const TC: ITypeCode): ITypeCode;
begin
  ORB.CreateSequenceTC(Bound, TC, Result);
end;

function TORB.MakeStructureTypeCode(const RepositoryID, Name: string; Members: TStructMembers): ITypeCode;
begin
  ORB.CreateStructTC(tk_struct, PChar(Pointer(RepositoryID)), PChar(Pointer(Name)),
    Members, Length(Members), Result);
end;

function TORB.MakeAliasTypeCode(const RepositoryID, Name: string; const TC: ITypeCode): ITypeCode;
begin
  ORB.CreateAliasTC(PChar(Pointer(RepositoryID)), PChar(Pointer(Name)), TC, Result);
end;

function TORB.MakeObjectRefTypeCode(const RepositoryID, Name: string): ITypeCode;
begin
  ORB.CreateObjRefTC(PChar(Pointer(RepositoryID)), PChar(Pointer(Name)), Result);
end;

function TORB.MakeComplexAny(TypeCode: ITypeCode; const Elements: array of TAny): TAny;
begin
  TVarData(Result).VType := varAny;
  TVarData(Result).VAny := ORB.MakeAny(TypeCode, Elements);
end;

function VariantArrayToSequence(TypeCode: ITypeCode; const VariantArray: Variant): TAny;
type
  PAnyArray = ^TAnyArray;
  TAnyArray = array[0..100] of TAny;
var
  P: PAnyArray;
  I, C: Integer;
begin
  if TVarData(VariantArray).VType <> varVariant or varArray then
    raise ECorbaDispatch.Create(sInvalidTypeCast)
  else
  begin
    I := VarArrayLowBound(VariantArray, 1);
    C := VarArrayHighBound(VariantArray, 1) - I + 1;
    if SafeArrayPtrOfIndex(GetVarArray(VariantArray), I, Pointer(P)) <> 0 then
      raise ECorbaDispatch.Create(sInvalidTypeCast);
    Result := ORB.MakeComplexAny(TypeCode, Slice(PAnyArray(P)^, C));
  end;
end;

function SequenceToVariantArray(Sequence: TAny): Variant;
begin
  if (TVarData(Sequence).VType and varArray <> 0) then
    Result := Sequence
  else if (TVarData(Sequence).VType <> varAny) or
    not SequenceToVariant(PCorbaAny(TVarData(Sequence).VPointer), @Result) then
    raise ECorbaDispatch.Create(sInvalidTypeCast);
end;

function AnyToObject(Any: TAny; IID: TGUID): IObject;
var
  Unk: IUnknown;
  Obj: ICorbaObj;
begin
  Unk := Any;
  Obj := Unk as ICorbaObj;
  if Obj.IsLocal then
    with Obj as ISkeleton do
      GetImplementation(Result)
  else
    Result := CorbaStubManager.CreateStub(IID, Obj as IStub);
end;

{ Marshalling methods }

procedure MarshalObject(const OutBuf: IMarshalOutBuffer; IID: TGUID;
  const Intf: IObject);
var
  StubObject: IStubObject;
  Stub: IStub;
  Skeleton: ISkeleton;
begin
  if Intf = nil then
  begin
    OutBuf.PutObject(nil);
    Exit;
  end;
  if Intf.QueryInterface(IStubObject, StubObject) = 0 then
  begin
    StubObject.GetStub(Stub);
    OutBuf.PutObject(Stub);
  end
  else
  begin
    with CorbaSkeletonManager.CreateSkeleton(IID, '', Intf) do
    begin
      _AddRef;
      GetSkeleton(Skeleton);
    end;
    OutBuf.PutObject(Skeleton);
  end;
end;

function UnmarshalObject(const InBuf: IMarshalInBuffer; IID: TGUID): IObject;
var
  Obj: ICorbaObj;
begin
  InBuf.GetObject(Obj);
  if Obj = nil then
  begin
    Result := nil;
    Exit;
  end;
  if Obj.IsLocal then
    with Obj as ISkeleton do
      GetImplementation(Result)
  else
    Result := CorbaStubManager.CreateStub(IID, Obj as IStub);
end;

procedure MarshalAny(const OutBuf: IMarshalOutBuffer; const OV: Variant);
var
  Temp: PCorbaAny;
begin
  Temp := VariantToAny(@OV);
  try
    OutBuf.PutAny(Temp);
  finally
    CorbaReleaseAny(Temp)
  end;
end;

function UnmarshalAny(const InBuf: IMarshalInBuffer): Variant;
var
  Temp: PCorbaAny;
begin
  Temp := InBuf.GetAny;
  try
    if not AnyToVariant(Temp, @Result) then
    begin
      TVarData(Result).VType := varAny;
      TVarData(Result).VAny := CorbaDuplicateAny(Temp);
      Exit;
    end
  finally
    CorbaReleaseAny(Temp);
  end;
end;

function UnmarshalText(const InBuf: IMarshalInBuffer): string;
var
  Temp: PChar;
begin
  Temp := InBuf.GetText;
  if (Temp <> nil) and (Temp[0] = #0) then
    Result := ''
  else
    Result := Temp;
  CorbaStringFree(Temp);
end;

function UnmarshalWideText(const InBuf: IMarshalInBuffer): WideString;
var
  Temp: PWideChar;
begin
  Temp := InBuf.GetWideText;
  Result := Temp;
  CorbaWStringFree(Temp);
end;

procedure MarshalWordBool(const OutBuf: IMarshalOutBuffer; Value: WordBool);
begin
  if Value then
    OutBuf.PutUnsignedChar(1)
  else
    OutBuf.PutUnsignedChar(0);
end;

function UnmarshalWordBool(const InBuf: IMarshalInBuffer): WordBool;
begin
  Result := InBuf.GetUnsignedChar <> 0;
end;

function CorbaFactoryCreateStub(const RepId, FactoryId, InstanceName, HostName: string;
  IID: TGUID): IObject;
var
  Factory: IStub;
  OutBuf: IMarshalOutBuffer;
  InBuf: IMarshalInBuffer;
  Obj: ICorbaObj;
begin
  BindStub(PChar(Pointer(RepId)), PChar(Pointer(FactoryId)),
    PChar(Pointer(HostName)), ORB.ORB, False, Factory);
  Factory.CreateRequest('CreateInstance', True, OutBuf);
  OutBuf.PutText(PChar(Pointer(InstanceName)));
  Factory.Invoke(OutBuf, InBuf);
  InBuf.GetObject(Obj);
  Result := CorbaStubManager.CreateStub(IID, Obj as IStub);
end;

procedure CorbaHookDispatch; forward;
procedure CorbaHookExceptions; forward;

function ORB: TORB;
begin
  if not Assigned(ORBVar) then
    CorbaInitialize;
  Result := ORBVar;
end;

function BOA: TBOA;
begin
  if not Assigned(BOAVar) then
    CorbaInitialize;
  Result := BOAVar;
end;

var
  Initialized: Boolean = False;
  
procedure CorbaInitialize;
begin
  if Initialized then Exit;
  Initialized := True;
  TORB.Initialize;
  CorbaFactoryManager.RegisterFactories;
  CorbaHookDispatch;
  CorbaHookExceptions;
end;

function CorbaBind(const RepositoryID: string; const ObjectName: string = '';
  const HostName: string = ''): IObject;
begin
  Result := ORB.Bind(RepositoryID, ObjectName, HostName);
end;

function CorbaBind(const InterfaceID: TGUID; const ObjectName: string = '';
  const HostName: string = ''): IObject;
begin
  Result := ORB.Bind(InterfaceID, ObjectName, HostName);
end;

function MakePrincipal(const Bytes: array of Byte): TCorbaPrincipal;
begin
  SetLength(Result, High(Bytes) + 1);
  Move(Bytes[0], Result[0], High(Bytes) + 1);
end;

{ CORBA Dispatch }

var
  OldVarDispProc: TVarDispProc;

procedure ClearAnyImpl(var V: Variant);
var
  P: Pointer;
begin
  if TVarData(V).VType = varAny then
  begin
    TVarData(V).VType := varEmpty;
    P := TVarData(V).VAny;
    if P <> nil then CorbaReleaseAny(P);
  end;
end;

procedure ChangeAnyImpl(var V: Variant);
var
  Tmp: Variant;
begin
  if TVarData(V).VType = varAny then
  begin
    if not AnyToVariant(PCorbaAny(TVarData(V).VAny), @Tmp) then
      raise ECorbaDispatch.Create(sInvalidTypeCast);
    V := Tmp;
  end;
end;

procedure RefAnyImpl(var V: Variant);
begin
  CorbaDuplicateAny(TVarData(V).VAny);
end;

procedure CorbaStructDispatch(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl; forward;
procedure CorbaObjectDispatch(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl; forward;

{$W-}
procedure CorbaDispProc;
asm
    MOV     EAX,[ESP+$8]
    CMP     [EAX].TVarData.VType,varAny
    JE      CorbaStructDispatch
    CMP     [EAX].TVarData.VType,varUnknown
    JE      CorbaObjectDispatch
    JMP     OldVarDispProc
end;

procedure CorbaDispatchError(Result: Integer; CallDesc: PCallDesc);
const
  NotCorbaObject = 0;
  InvalidParamCount = $1FFF;
  MethodNotFound = $1FFE;
  NoRepository = $1FFD;
var
  Msg: string;

  function MethodName: string;
  begin
    Result := PChar(@CallDesc^.ArgTypes[CallDesc^.ArgCount]);
  end;

begin
  case Result of
    InvalidParamCount: Msg := Format(sInvalidParameterCount, [MethodName]);
    MethodNotFound: Msg := Format(sMethodNotFound, [MethodName]);
    NoRepository: Msg := sNoRepository;
    NotCorbaObject: Msg := sNotCorbaObject;
  else
    if Result < 0 then
      Msg := Format(sParamOut, [-Result, MethodName]) else
      Msg := Format(sParamTypeCast, [Result, MethodName]);
  end;
  raise ECorbaDispatch.Create(Msg);
end;

procedure CorbaStructDispatch(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl;
var
  R: Integer;
  ProcResult: Variant;
begin
  if Result = nil then Result := @ProcResult;
  R := ORB.ORB.DispatchStruct(TVarData(Instance).VAny, CallDesc,
    Params, Result^);
  if R <> 0 then
    CorbaDispatchError(R, CallDesc)
  else if CallDesc.CallType = DISPATCH_PROPERTYPUT then
    PVariant(@Instance)^ := Result^;
end;

procedure CorbaObjectDispatch(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl;
var
  U: IUnknown;
  StubObject: IStubObject;
  Stub: IStub;
  R: Integer;
  ProcResult: Variant;
begin
  if Result = nil then Result := @ProcResult;
  U := IUnknown(Instance);
  if U.QueryInterface(IStubObject, StubObject) = 0 then
    StubObject.GetStub(Stub)
  else if U.QueryInterface(IStub, Stub) <> 0 then
    CorbaDispatchError(0, CallDesc);
  R := Stub.Dispatch(CallDesc, Params, Result^);
  if R <> 0 then CorbaDispatchError(R, CallDesc);
end;

procedure CorbaHookDispatch;
begin
  ClearAnyProc := @ClearAnyImpl;
  ChangeAnyProc := @ChangeAnyImpl;
  RefAnyProc := @RefAnyImpl;
  OldVarDispProc := VarDispProc;
  VarDispProc := @CorbaDispProc;
end;

procedure CorbaUnhookDispatch;
begin
  if @ClearAnyProc = @ClearAnyImpl then
  begin
    ClearAnyProc := nil;
    ChangeAnyProc := nil;
    RefAnyProc := nil;
  end;
  if @VarDispProc = @CorbaDispProc then
    VarDispProc := OldVarDispProc;
end;

{ Corba exception mapper }
type
  TExceptClassProc = function (P: PExceptionRecord): ExceptClass;
  TExceptObjectProc = function (P: PExceptionRecord): Exception;

var
  OldExceptClassProc: TExceptClassProc;
  OldExceptObjectProc: TExceptObjectProc;

const
  cCPPException = $EEFFACE;

function IsCorba(P: PChar): Boolean;
begin
  Result := (P <> nil) and (StrLComp('CORBA_', P, 6) = 0);
end;

function CorbaGetExceptClass(P: PExceptionRecord): ExceptClass;
begin
  if (P.ExceptionCode = cCPPException) and
    IsCorba(PChar(P.ExceptionInformation[0])) then
    Result := ECorbaException else
    Result := OldExceptClassProc(P);
end;

function CorbaGetExceptObject(P: PExceptionRecord): Exception;
begin
  if (P.ExceptionCode = cCPPException) and
    IsCorba(PChar(P.ExceptionInformation[0])) then
    Result := ECorbaException.Create(PChar(@PChar(P.ExceptionInformation[0])[6])) else
    Result := OldExceptObjectProc(P);
end;

procedure CorbaHookExceptions;
begin
  OldExceptClassProc := ExceptClsProc;
  OldExceptObjectProc := ExceptObjProc;
  ExceptClsProc := @CorbaGetExceptClass;
  ExceptObjProc := @CorbaGetExceptObject;
end;

procedure CorbaUnhookExceptions;
begin
  if ExceptClsProc = @CorbaGetExceptClass then
  begin
    ExceptClsProc := @OldExceptClassProc;
    ExceptObjProc := @OldExceptObjectProc;
  end;
end;

initialization
  CorbaSkeletonManager := TCorbaSkeletonManager.Create;
  CorbaStubManager := TCorbaStubManager.Create;
  CorbaFactoryManager := TCorbaFactoryManager.Create;
  CorbaInterfaceIDManager := TCorbaInterfaceIDManager.Create;
  CorbaStubManager.RegisterStub(IStub, TCorbaStub);

finalization
  CorbaSkeletonManager.Free;
  CorbaStubManager.Free;
  CorbaFactoryManager.Free;
  CorbaInterfaceIDManager.Free;
  BOAVar.Free;
  ORBVar.Free;
  CorbaUnhookDispatch;
  CorbaUnhookExceptions;

end.