[fpc-devel] Interfaced Object leak in inherited Object

[alphax]

It seems a bug in FPC 2.0.0.(Delphi 7.1 also has this bug)

Assumes there is an object(not class) declaration, the object has a IInterface field. If we declare another object derive from it, in the cleanup procedure of that decendant leak to clear the IInterface references.

The test program is follow:
//===================================================================

program test_obj_inherit;
{
  bug: Interfaced Object leak in inherited Object
  environment: win2k fpc2.0.0
  date: 2005.06.13
}

{$mode objfpc}

uses
  SysUtils, Variants;

type
  TInterfacedObj = class(TInterfacedObject)
    destructor Destroy; override;
  end;

  TObj1 = object
    I: IInterface;
    constructor Create;
    procedure Which; virtual;
  end;
  PObj1 = ^TObj1;

  TObj2 = object(TObj1)
    constructor Create;
    procedure Which; virtual;
  end;
  PObj2 = ^TObj2;

  TObj3 = object(TObj1)
    //object keep a Variant
    V: Variant;
    constructor Create;
    procedure Which; virtual;
  end;
  PObj3 = ^TObj3;

var
  //used to check the interfaced object is whether or not released
  InterfacedObjReleased: Boolean;

destructor TInterfacedObj.Destroy;
  begin
    InterfacedObjReleased := True;
  end;

constructor TObj1.Create;
  begin
  end;

procedure TObj1.Which;
  begin
    WriteLn('  This is TObj1');
  end;

constructor TObj2.Create;
  begin
  end;

procedure TObj2.Which;
  begin
    WriteLn('  This is TObj2');
  end;

constructor TObj3.Create;
  begin
  end;

procedure TObj3.Which;
  begin
    WriteLn('  This is TObj3');
  end;

{==Test TObj1==}

procedure Test1_1;
  var
    Obj: PObj1;
  begin
    WriteLn('Use Object Pointer');
    New(Obj, Create);
    Obj^.I := TInterfacedObj.Create();
    Obj^.Which();
    Dispose(Obj);
  end;

procedure Test1_2;
  var
    Obj: TObj1;
  begin
    WriteLn('Use Object directly');
    Obj.Create();
    Obj.I := TInterfacedObj.Create();
    Obj.Which();
  end;

{==Test TObj2==}

procedure Test2_1;
  var
    Obj: PObj2;
  begin
    WriteLn('Use Object Pointer');
    Obj := New(PObj2, Create);
    Obj^.I := TInterfacedObj.Create();
    Obj^.Which();
    Dispose(Obj); //here, the I should be release
  end;

procedure Test2_2;
  var
    Obj: TObj2;
  begin
    WriteLn('Use Object directly');
    Obj.Create();
    Obj.I := TInterfacedObj.Create();
    Obj.Which();
  end; //afetr Test2_2 return the I should be release

{==Test TObj3==}

operator := (const I: IInterface): Variant;
  begin
    VarClear(Result);

    with TVarData(Result) do
    begin
      vtype := varunknown;
      IInterface(vunknown) := I;
    end;
  end;

procedure Test3_1;
  var
    Obj: PObj3;
  begin
    WriteLn('Use Object Pointer');
    Obj := New(PObj3, Create);
    Obj^.V := TInterfacedObj.Create();
    Obj^.Which();
    Dispose(Obj); //here, the V should be cleanup
  end;

procedure Test3_2;
  var
    Obj: TObj3;
  begin
    WriteLn('Use Object directly');
    Obj.Create();
    Obj.V := TInterfacedObj.Create();
    Obj.Which();
  end; //afetr Test3_2 return the V should be cleanup



procedure CheckReleased;
  begin
    if InterfacedObjReleased then
      WriteLn('  InterfacedObject Release, OK')
    else
      WriteLn('  InterfacedObject is *NOT* Released, Failure');

    WriteLn;

    InterfacedObjReleased := False;
  end;


begin
  WriteLn;

  Test1_1();
  CheckReleased();
  Test1_2();
  CheckReleased();

  Test2_1();  //<- The InterfacedObject leak in this call
  CheckReleased();
  Test2_2();  //<- The InterfacedObject leak in this call
  CheckReleased();

  Test3_1();
  CheckReleased();
  Test3_2();
  CheckReleased();

  WriteLn;
end.
//===================================================================