corbaobj.pas

三层的通用架构

{ TCorbaInterfaceIDManager }

function TCorbaInterfaceIDManager.FindID(const IID: TGUID): string;
begin
  if not SearchID(IID, Result) then
    raise ECorbaException.CreateRes(@SCorbaInterfaceIDNotRegister);
end;

function TCorbaInterfaceIDManager.FindGUID(const RepositoryID: string): TGUID;
begin
  if not SearchGUID(RepositoryID, Result) then
    raise ECorbaException.CreateResFmt(@SCorbaRepositoryIDNotRegistered, [RepositoryID]);
end;

procedure TCorbaInterfaceIDManager.RegisterInterface(const IID: TGUID;
  const RepositoryID: string);
var
  L: Integer;
begin
  BeginWrite;
  try
    L := Length(FList);
    if FUsed = L then
    begin
      if L = 0 then L := 8 else L := L * 2;
      SetLength(FList, L);
    end;
    FList[FUsed].IID := IID;
    FList[FUsed].RepositoryID := RepositoryID;
    Inc(FUsed);
  finally
    EndWrite;
  end;
end;

function TCorbaInterfaceIDManager.SearchGUID(const RepositoryID: string;
  out IID: TGUID): Boolean;
var
  I: Integer;
begin
  BeginRead;
  try
    for I := 0 to FUsed - 1 do
      if FList[I].RepositoryID = RepositoryID then
      begin
        IID := FList[I].IID;
        Result := True;
        Exit;
      end;
  finally
    EndRead;
  end;
  Result := False;
end;

function TCorbaInterfaceIDManager.SearchID(const IID: TGUID;
  out RepositoryID: string): Boolean;
var
  I: Integer;
begin
  BeginRead;
  try
    for I := 0 to FUsed - 1 do
      if IsEqualGUID(FList[I].IID, IID) then
      begin
        RepositoryID := FList[I].RepositoryID;
        Result := True;
        Exit;
      end;
  finally
    EndRead;
  end;
  Result := False;
end;

{ TCorbaSkeletonManager }

procedure TCorbaSkeletonManager.RegisterSkeleton(IID: TGUID;
  Skeleton: TCorbaSkeletonClass);
var
  L: Integer;
begin
  BeginWrite;
  try
    L := Length(FList);
    if FUsed = L then
    begin
      if L = 0 then L := 8 else L := L * 2;
      SetLength(FList, L);
    end;
    FList[FUsed].IID := IID;
    FList[FUsed].SkeletonClass := Skeleton;
    Inc(FUsed);
  finally
    EndWrite;
  end;
end;

function TCorbaSkeletonManager.CreateSkeleton(IID: TGUID;
  const InstanceName: string; const Impl: IObject): ISkeletonObject;
var
  I: Integer;
begin
  BeginRead;
  try
    for I := 0 to FUsed - 1 do
      if IsEqualGUID(FList[I].IID, IID) then
      begin
        Result := FList[I].SkeletonClass.Create(InstanceName, Impl);
        Exit;
      end;
  finally
    EndRead;
  end;
  raise Exception.CreateResFmt(@SCorbaSkeletonNotRegistered, [InstanceName]);
end;

{ TCorbaStubManager }

procedure TCorbaStubManager.RegisterStub(IID: TGUID; Stub: TCorbaStubClass);
var
  L: Integer;
begin
  BeginWrite;
  try
    L := Length(FList);
    if FUsed = L then
    begin
      if L = 0 then L := 8 else L := L * 2;
      SetLength(FList, L);
    end;
    FList[FUsed].IID := IID;
    FList[FUsed].StubClass := Stub;
    Inc(FUsed);
  finally
    EndWrite;
  end;
end;

function TCorbaStubManager.CreateStub(IID: TGUID; const Stub: IStub): IObject;
var
  I: Integer;
begin
  BeginRead;
  try
    for I := 0 to FUsed - 1 do
      if IsEqualGUID(FList[I].IID, IID) then
      begin
        Result := FList[I].StubClass.Create(Stub);
        Exit;
      end;
  finally
    EndRead;
  end;
  raise Exception.CreateRes(@SCorbaStubNotRegistered);
end;

{ TCorbaImplementation }

constructor TCorbaImplementation.Create(Controller: IObject; AFactory: TCorbaFactory);
begin
  inherited Create;
  FFactory := AFactory;
  FController := Pointer(Controller);
end;

function TCorbaImplementation._AddRef: Integer;
begin
  if Assigned(FController) then
    Result := IObject(FController)._AddRef else
    Result := ObjAddRef;
end;

function TCorbaImplementation._Release: Integer;
begin
  if Assigned(FController) then
    Result := IObject(FController)._Release else
    Result := ObjRelease;
end;

function TCorbaImplementation.ObjAddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TCorbaImplementation.ObjQueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
end;

function TCorbaImplementation.ObjRelease: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then Destroy;
end;

function TCorbaImplementation.QueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  if Assigned(FController) then
    Result := IObject(FController).QueryInterface(IID, Obj) else
    Result := ObjQueryInterface(IID, Obj);
end;

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

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

function TCorbaImplementation.GetTypeInfoCount(
  out Count: Integer): HResult;
begin
  Count := 1;
  Result := S_OK;
end;

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

{ TCorbaFactory }

constructor TCorbaFactory.Create(const InterfaceName, InstanceName,
  RepositoryId: string; const ImplGUID: TGUID;
  Instancing: TCorbaInstancing;
  ThreadModel: TCorbaThreadModel);
begin
  inherited Create;
  FIID := ImplGUID;
  FInterfaceName := InterfaceName;
  FInstanceName := InstanceName;
  FRepositoryId := RepositoryId;
  FInstancing := Instancing;
  FThreadModel := ThreadModel;
  CorbaFactoryManager.AddFactory(Self);
end;

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

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

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

function TCorbaFactory.Execute(Operation: PChar; const Strm: IMarshalInBuffer;
 Cookie: Pointer): CorbaBoolean;
var
  InstanceName: string;
  OutBuff: IMarshalOutBuffer;
  Skeleton: ISkeleton;
begin
  Result := False;
  if CompareStr(Operation, 'CreateInstance') <> 0 then Exit;
  InstanceName := UnmarshalText(Strm);
  if FSingleInstanceSkelton <> nil then
    with FSingleInstanceSkelton do
    begin
      _AddRef;
      GetSkeleton(Skeleton);
    end
  else
    with CreateInstance(InstanceName) do
      GetSkeleton(Skeleton);
  FSkeleton.GetReplyBuffer(Cookie, OutBuff);
  OutBuff.PutObject(Skeleton);
  Result := True;
end;

procedure TCorbaFactory.RegisterFactory;
begin
  CreateSkeleton(PChar(Pointer(FInterfaceName)), Self, True,
    PChar(Pointer(FInstanceName)), PChar(Pointer(FRepositoryId)), False,
    FSkeleton);
  BOA.ObjIsReady(FSkeleton);
  if FInstancing = iSingleInstance then
    FSingleInstanceSkelton := CreateInstance('');
end;

function TCorbaFactory.CreateInstance(const InstanceName: string): ISkeletonObject;
var
  Intf: IObject;
begin
  Intf := CreateInterface(InstanceName);
  Result := CorbaSkeletonManager.CreateSkeleton(FIID, InstanceName, Intf);
  if Assigned(Result) then Result._AddRef;
end;

function TCorbaFactory.CreateInterface(const InstanceName: string): IObject;
begin
  raise ECorbaException.CreateRes(@SCorbaIncompleteFactory);
end;

function TCorbaFactory.GetTypeInfo(out TypeInfo): HRESULT;
var
  TypeLib: ITypeLib;
  Buffer: array[0..261] of Char;
begin
  if not Assigned(FTypeInfo) then
  begin
    Windows.GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
    Result := LoadTypeLib(PWideChar(WideString(Buffer)), TypeLib);
    if Result <> S_OK then Exit;
    Result := TypeLib.GetTypeInfoOfGUID(FIID, FTypeInfo);
    if Result <> S_OK then Exit;
  end;
  ITypeInfo(TypeInfo) := FTypeInfo;
  Result := S_OK;
end;

{ TCorbaFactoryManager }

destructor TCorbaFactoryManager.Destroy;
var
  I: Integer;
begin
  for I := 0 to FUsed - 1 do FList[I].Free;
  inherited Destroy;
end;

procedure TCorbaFactoryManager.AddFactory(Factory: TCorbaFactory);
var
  L: Integer;
begin
  BeginWrite;
  try
    L := Length(FList);
    if FUsed = L then
    begin
      if L = 0 then L := 8 else L := L * 2;
      SetLength(FList, L);
    end;
    FList[FUsed] := Factory;
    Inc(FUsed);
  finally
    EndWrite;
  end;
  if FRegistered then Factory.RegisterFactory;
end;

procedure TCorbaFactoryManager.RegisterFactories;
var
  DoRegister: Boolean;
  Used: Integer;
  I: Integer;
begin
  if not FRegistered then
  begin
    // Assumes only adding of factories are possible.
    // If removing is possilbe the Read/Write blocks need to be nested.
    BeginWrite;
    try
      Used := FUsed;
      DoRegister := not FRegistered;
      FRegistered := True;
    finally
      EndWrite;
    end;
    if DoRegister then
    begin
      BeginRead;
      try
        for I := 0 to Used - 1 do FList[I].RegisterFactory;
      finally
        EndRead;
      end;
    end;
  end;
end;

function TCorbaFactoryManager.Find(const RepositoryID, InterfaceName,
  InstanceName: string): TCorbaFactory;
var
  I: Integer;
begin
  if (InterfaceName <> '') or (RepositoryID <> '') then
  begin
    BeginRead;
    try
      for I := 0 to FUsed - 1 do
      begin
        Result := FList[I];
        if ((RepositoryID = '') or (RepositoryID = Result.RepositoryID)) and
          ((InterfaceName = '') or (InterfaceName = Result.InterfaceName)) and
          ((InstanceName = '') or (InstanceName = Result.InstanceName)) then
          Exit;
      end;
      Result := nil;
    finally
      EndRead;
    end;
  end
  else Result := nil;
end;

{ TCorbaObjectFactory }

constructor TCorbaObjectFactory.Create(const InterfaceName, InstanceName,
  RepositoryId: string; const ImplGUID: TGUID;
  ImplementationClass: TCorbaImplementationClass;
  Instancing: TCorbaInstancing; ThreadModel: TCorbaThreadModel);
begin
  inherited Create(InterfaceName, InstanceName, RepositoryID, ImplGUID,
    Instancing, ThreadModel);
  FImplementationClass := ImplementationClass;
end;

function TCorbaObjectFactory.CreateInterface(const InstanceName: string): IObject;
begin
  Result := FImplementationClass.Create(nil, Self);
end;

{ TBOA }

class procedure TBOA.Initialize(const CommandLine: TCommandLine);
begin
  if CorbaObj.BOAVar = nil then
  begin
    CorbaObj.BOAVar := TBOA.Create;
    CorbaObj.ORBVar.ORB.BOAInit(Length(CommandLine), CommandLine, CorbaObj.BOAVar.BOA);
  end;
end;

function TBOA.GetPrincipal(const Obj: IObject): TCorbaPrincipal;
var
  Length: Integer;
  Skeleton: ISkeleton;
begin
  if Obj.QueryInterface(ISkeleton, Skeleton) <> S_OK then
    (Obj as ISkeletonObject).GetSkeleton(Skeleton);
  Length := BOA.GetPrincipalLength(Skeleton);
  SetLength(Result, Length);
  BOA.GetPrincipal(Skeleton, @Result[0]);
end;

procedure TBOA.Deactivate(const Obj: IObject);
begin
  BOA.Deactivate(Obj as ISkeleton);
end;

procedure TBOA.ImplIsReady;
begin
  BOA.ImplIsReady;
end;

procedure TBOA.ObjIsReady(const Obj: IObject);
begin
  BOA.ObjIsReady(Obj as ISkeleton);
end;

{ TORB }
class procedure TORB.Initialize(const CommandLine: TCommandLine);
begin
  CorbaObj.ORBVar := TORB.Create;
  InitORB(CommandLine, CorbaObj.ORBVar.ORB);
end;

class procedure TORB.Initialize;
var
  CommandLine: TCommandLine;
  I: Integer;
begin
  if CorbaObj.ORBVar = nil then
  begin
    SetLength(CommandLine, ParamCount + 1);
    for I := 0 to ParamCount do CommandLine[I] := ParamStr(I);
    Initialize(CommandLine);
    if BOAVar = nil then TBOA.Initialize(CommandLine);
  end;
end;

function InternalBind(const RepositoryID, ObjectName, HostName: string): IStub;
begin
  BindStub(PChar(Pointer(RepositoryID)), PChar(Pointer(ObjectName)),
    PChar(Pointer(HostName)), ORB.ORB,
    False, Result)
end;

function TORB.Bind(const InterfaceID: TGUID; const ObjectName,
  HostName: string): IObject;
begin
  Result := CorbaStubManager.CreateStub(InterfaceID,
    InternalBind(CorbaInterfaceIDManager.FindID(InterfaceID),
    ObjectName, HostName));
end;

function TORB.Bind(const RepositoryID, ObjectName, HostName: string): IObject;
var
  Stub: IStub;
  IID: TGUID;
begin
  Stub := InternalBind(RepositoryID, ObjectName, HostName);
  if not CorbaInterfaceIDManager.SearchGUID(RepositoryID, IID) then
    IID := IStub;
  Result := CorbaStubManager.CreateStub(IID, Stub);
end;

function TORB.ObjectToString(const Obj: IObject): string;
var
  Stub: IStub;
  P: PChar;
begin
  if Obj.QueryInterface(IStub, Stub) <> S_OK then
    (Obj as IStubObject).GetStub(Stub);
  P := ORB.ObjectToString(Stub);
  Result := P;
  CorbaStringFree(P);
end;

function TORB.StringToObject(const ObjectString: string): IObject;
var
  Stub: IStub;
  ID: PChar;
begin
  ORB.StringToObject(PChar(Pointer(ObjectString)), Stub);