Email服务器

开发平台：
Delphi

XPInterfacedObjectTests.pas：源码内容
							unit XPInterfacedObjectTests;
interface
uses
  XPInterfacedObject,
  TestFrameWork;
type
  IXPCrackedInterface = interface(IInterface)
    ['{2ECEC777-1C1B-4797-8916-4D7139BA4392}']
    function RefCount: integer;
  end;
  TXPInterfacedObjectTests = class(TTestCase)
  private
    FDelegator: IXPCrackedInterface;
    FContained: IInterface;
    FXPContained: IXPCrackedInterface;
    FCleverDelegator: IInterface;
  protected
    procedure SetUp; override;
    procedure TearDown; override;
  published
    // Test methods
    procedure TestQueryInterface;
    procedure Test_AddRef;
    procedure Test_AddRefXP;
    procedure Test_Release;
    procedure TestCreate;
    procedure TestCreateXP;
    procedure TestDestroy;
    procedure TestDelegation;
    procedure TestIntrospective;
  end;
implementation
uses
  SysUtils;
type
  // Access FRefCount
  TCrackedInterface = class(TInterfacedObject, IXPCrackedInterface)
  protected
    function RefCount: integer;
  public
    destructor Destroy; override;
  end;
  TXPCrackedInterface = class(TXPInterfacedObject, IXPCrackedInterface)
  protected
    function RefCount: integer;
  public
    destructor Destroy; override;
  end;
  IA = interface
    ['{CEBA0535-4909-4605-8AFC-844092A36D47}']
    function A: integer;
  end;
  IB = interface
    ['{121BAA8A-A52B-4FA1-9729-3A8E744E1F41}']
    function B: integer;
  end;
  IC = interface
    ['{AA3CCF11-704B-414D-B6F5-514493D09D38}']
    function C: integer;
  end;
  ID = interface
    ['{B028B140-AFB2-49D8-9A71-CE82555080DA}']
    function D: integer;
  end;
  TClever = class(TInterfacedObject, IA, IB)
  protected
    function A: integer;
    function B: integer;
  end;
  TUnOwnedDelegatee = class(TInterfacedObject, IC)
  protected
    function C: integer;
  end;
  TOwnedDelegatee = class(TXPInterfacedObject, ID)
  protected
    function D: integer;
  end;
  TDelegator = class (TCrackedInterface, IC, ID)
  private
    FUnOwned: TUnOwnedDelegatee;
    FOwned: TOwnedDelegatee;
  protected
    property UnOwned: TUnOwnedDelegatee
      read FUnOwned implements IC;
    property Owned: TOwnedDelegatee
      read FOwned implements ID;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetIntrospective(Value: boolean);
  end;
{ TXPInterfacedObjectTests }
procedure TXPInterfacedObjectTests.SetUp;
begin
  inherited;
  FDelegator := TCrackedInterface.Create;
  FCleverDelegator := TClever.Create;
end;
procedure TXPInterfacedObjectTests.TearDown;
begin
  FXPContained := nil;
  FContained := nil;
  FDelegator := nil;
  FCleverDelegator := nil;
  inherited;
end;
procedure TXPInterfacedObjectTests.Test_AddRef;
begin
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned construction');
  FContained._AddRef;
  CheckEquals(3, FDelegator.RefCount, 'Bad rc after owned addref');
  FContained._AddRef;
  CheckEquals(4, FDelegator.RefCount, 'Bad rc after second owned addref');
  FContained._Release;
  FContained._Release;
end;
procedure TXPInterfacedObjectTests.Test_Release;
begin
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned construction');
  FContained._AddRef;
  CheckEquals(3, FDelegator.RefCount, 'Bad rc after owned addref');
  FContained._AddRef;
  CheckEquals(4, FDelegator.RefCount, 'Bad rc after owned second addref');
  FContained._Release;
  CheckEquals(3, FDelegator.RefCount, 'Bad rc after owned release');
  FContained._Release;
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned second release');
  FContained := nil;
  CheckEquals(1, FDelegator.RefCount, 'Bad rc after owned nil''d');
end;
procedure TXPInterfacedObjectTests.TestCreate;
begin
  CheckEquals(1, FDelegator.RefCount, 'Initial rc for Delegator');
  FContained := TXPInterfacedObject.Create;
  CheckEquals(1, FDelegator.RefCount, 'Bad rc after default construction');
  FContained := TXPInterfacedObject.Create(nil);
  CheckEquals(1, FDelegator.RefCount, 'Bad rc after nil construction');
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned construction');
end;
procedure TXPInterfacedObjectTests.TestDestroy;
begin
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned construction');
  FContained := nil;
  CheckEquals(1, FDelegator.RefCount, 'Bad rc after owned destruction');
end;
procedure TXPInterfacedObjectTests.TestQueryInterface;
var
  A: IA;
  B: IB;
begin
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FCleverDelegator);
  Check(SysUtils.Supports(FContained, IA, A), 'Not finding IA through owned');
  CheckEquals(1, A.A, 'queried IA.A failed');
  CheckEquals(1, (FContained as IA).A, '(FContained as IA).A failed');
  Check(SysUtils.Supports(FContained, IB, B), 'Not finding IB through owned');
  CheckEquals(2, B.B, 'queried IB.B failed');
  CheckEquals(2, (FContained as IB).B, '(FContained as IB).B failed');
  // Drop reference to container and query containers interfaces through
  // contained reference
  A := nil;
  B := nil;
  FCleverDelegator := nil;
  Check(SysUtils.Supports(FContained, IA, A),
    'Not finding IA through owned after container released');
  CheckEquals(1, A.A, 'queried IA.A failed  after container released');
  CheckEquals(1, (FContained as IA).A,
    '(FContained as IA).A failed  after container released');
  Check(SysUtils.Supports(FContained, IB, B),
    'Not finding IB through owned  after container released');
  CheckEquals(2, B.B, 'queried IB.B failed  after container released');
  CheckEquals(2, (FContained as IB).B,
    '(FContained as IB).B failed  after container released');
end;
procedure TXPInterfacedObjectTests.TestCreateXP;
begin
  FXPContained := TXPCrackedInterface.Create;
  CheckEquals(1, FXPContained.RefCount, 'Initial rc for unowned xp');
  FXPContained := nil;
  FXPContained := TXPCrackedInterface.Create(nil);
  CheckEquals(1, FXPContained.RefCount, 'Initial rc for unowned (nil) xp');
  FXPContained := nil;
  FXPContained := TXPCrackedInterface.Create;
  CheckEquals(1, FXPContained.RefCount, 'Initial rc for unowned xp');
  FXPContained := TXPCrackedInterface.Create(nil);
  CheckEquals(1, FXPContained.RefCount,
    'Initial rc for unowned (nil) xp - no intervening nil');
  FXPContained := nil;
  CheckEquals(1, FDelegator.RefCount, 'Initial rc for Delegator');
  // Memory leak created here, as there is no way to call FXPContained
  // destructor
  FXPContained := TXPCrackedInterface.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned xp construction');
  CheckEquals(1, FXPContained.RefCount, 'Initial rc for owned xp');
  // Memory leak created here, as there is no way to call FContained destructor
  FContained := TXPInterfacedObject.Create(FDelegator);
  CheckEquals(3, FDelegator.RefCount,
    'Bad rc after owned construction with xp on board');
  CheckEquals(1, FXPContained.RefCount,
    'Bad rc for owned xp afer owned added to delegator');
  FContained := nil;
  CheckEquals(2, FDelegator.RefCount,
    'Bad rc after owned nil''d with xp on board');
  CheckEquals(1, FXPContained.RefCount,
    'Bad rc for owned xp after owned nil''d with xp on board');
end;
procedure TXPInterfacedObjectTests.Test_AddRefXP;
begin
  // Memory leak created here, as there is no way to call FXPContained
  // destructor
  FXPContained := TXPCrackedInterface.Create(FDelegator);
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned construction');
  CheckEquals(1, FXPContained.RefCount, 'Initial rc for owned xp');
  FXPContained._AddRef;
  CheckEquals(3, FDelegator.RefCount, 'Bad rc after owned addref');
  CheckEquals(2, FXPContained.RefCount, 'Bad rc for addref''d xp');
  FXPContained._AddRef;
  CheckEquals(4, FDelegator.RefCount, 'Bad rc after second owned addref');
  CheckEquals(3, FXPContained.RefCount, 'Bad rc for second addref''d xp');
  FXPContained._Release;
  CheckEquals(3, FDelegator.RefCount, 'Bad rc after owned released xp');
  CheckEquals(2, FXPContained.RefCount, 'Bad rc for released xp');
  FXPContained._Release;
  CheckEquals(2, FDelegator.RefCount, 'Bad rc after owned second released xp');
  CheckEquals(1, FXPContained.RefCount, 'Bad rc for second released xp');
end;
procedure TXPInterfacedObjectTests.TestDelegation;
var
  Delegator: IXPCrackedInterface;
  Unowned: IC;
  Owned: ID;
begin
  Delegator := TDelegator.Create;
  CheckEquals(1, Delegator.RefCount, 'Delegator rc after construction');
  Check(SysUtils.Supports(Delegator, IC, Unowned), '1st query for unowned');
  CheckEquals(1, Delegator.RefCount, 'Delegator rc after querying for unowned');
  CheckEquals(3, Unowned.C, 'Called method on IC interface');
  Unowned := nil;
{
  // Uncomment this to see an invalid pointer op, since we have just destroyed
  // the implementing object for IC, and now have a dangling reference within
  // the TDelegator container
  Check(SysUtils.Supports(Delegator, IC, Unowned),
    'query for unowned after reference released');
}
  CheckEquals(1, Delegator.RefCount, 'Delegator rc after unowned released');
  Check(SysUtils.Supports(Delegator, ID, Owned), '1st query for owned');
  CheckEquals(2, Delegator.RefCount, 'Delegator rc after querying for owned');
  CheckEquals(4, Owned.D, 'Called method on ID interface');
  Owned := nil;
  CheckEquals(1, Delegator.RefCount, 'Delegator rc after owned released');
  // Try op that fails for Unowned - fetch owned ref again
  Check(SysUtils.Supports(Delegator, ID, Owned), '2nd query for owned');
  CheckEquals(2, Delegator.RefCount, 'Delegator rc after 2nd query for owned');
  CheckEquals(4, Owned.D, 'Called method on ID interface after 2nd query');
end;
procedure TXPInterfacedObjectTests.TestIntrospective;
var
  Delegator: TDelegator;
  Cracked: IXPCrackedInterface;
  Owned: ID;
begin
  Delegator := TDelegator.Create;
  CheckEquals(0, Delegator.RefCount, 'Delegator rc after construction');
  Check(SysUtils.Supports(TObject(Delegator), ID, Owned), '1st query for owned');
  CheckEquals(1, Delegator.RefCount, 'Delegator rc after querying for owned');
  CheckEquals(4, Owned.D, 'Called method on ID interface');
  // default introspective setting
  Check(SysUtils.Supports(Owned, IXPCrackedInterface, Cracked),
    'query for delegator interface through owned');
  CheckEquals(2, Delegator.RefCount,
    'Delegator rc after query for delegator interface through owned');
  // true introspective setting
  Delegator.SetIntrospective(true);
  Check(not SysUtils.Supports(Owned, IXPCrackedInterface, Cracked),
    'query for delegator interface through owned with introspective true');
  // false introspective setting
  Delegator.SetIntrospective(false);
  Check(SysUtils.Supports(Owned, IXPCrackedInterface, Cracked),
    'query for delegator interface through owned with introspective false');
  CheckEquals(2, Delegator.RefCount,
    'Delegator rc after query for delegator interface through owned (false)');
  Cracked := nil;
  CheckEquals(1, Delegator.RefCount,
    'Delegator rc after Cracked = nil');
  Owned := nil;
end;
{ TCrackedInterface }
destructor TCrackedInterface.Destroy;
begin
  inherited;
end;
function TCrackedInterface.RefCount: integer;
begin
  Result := FRefCount;
end;
{ TXPCrackedInterface }
destructor TXPCrackedInterface.Destroy;
begin
  inherited;
end;
function TXPCrackedInterface.RefCount: integer;
begin
  Result := FRefCount;
end;
{ TClever }
function TClever.A: integer;
begin
  Result := 1;
end;
function TClever.B: integer;
begin
  Result := 2;
end;
{ TDelegator }
constructor TDelegator.Create;
begin
  inherited;
  FUnOwned := TUnOwnedDelegatee.Create;
  FOwned := TOwnedDelegatee.Create(self);
end;
destructor TDelegator.Destroy;
begin
  // We are not knocking off FUnowned as this will be destroyed through
  // releasing a reference in the test
  FOwned.Free;
  inherited;
end;
procedure TDelegator.SetIntrospective(Value: boolean);
begin
  FOwned.Introspective := Value;
end;
{ TUnOwnedDelegatee }
function TUnOwnedDelegatee.C: integer;
begin
  Result := 3;
end;
{ TOwnedDelegatee }
function TOwnedDelegatee.D: integer;
begin
  Result := 4;
end;
initialization
  TestFramework.RegisterTest('XPInterfacedObjectTests Suite',
    TXPInterfacedObjectTests.Suite);
end.

						