[fpc-pascal] Delegate Interface class does not seem to be referenced counted

[Tony Whyman]

I'm using fpc 3.0.0 and trying to debug a program using COM interfaces. 
While reference counting seems to be working fine, there is one 
exception, that is when an interface is being used by delegation. In 
this case, the object doing the delegation does not seem to be reference 
counted. Is this a bug, a feature, or have I missed something?

A simple test program follows. The output is:
Creating TDelegateClass
Creating TMyClass
Creating TDelegateClass
Destroying TDelegateClass
Destroying TDelegateClass

In the example, TMyClass is the interface class doing the delegation and 
while TDelegateClass is being destroyed when it goes out of scope, 
TMyClass is not.

Tony Whyman

MWA

program project1;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes, SysUtils, CustApp
  { you can add units after this };

type

  { TDelegateTest }

  TDelegateTest = class(TCustomApplication)
  protected
    procedure DoRun; override;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure WriteHelp; virtual;
  end;

  IMyInterface = interface
     procedure P1;
   end;

    { TDelegateClass }

   TDelegateClass = class(TInterfacedObject, IMyInterface)
   private
     procedure P1;
   public
     constructor Create;
     destructor Destroy; override;
   end;

   { TMyClass }

   TMyClass = class(TInterfacedObject, IMyInterface)
   private
     FMyInterface: TDelegateClass; // class type
     property MyInterface: TDelegateClass
       read FMyInterface implements IMyInterface;
   public
     constructor Create(obj: TDelegateClass);
     destructor Destroy; override;
   end;

{ TDelegateClass }

procedure TDelegateClass.P1;
begin
  writeln('P1');
end;

constructor TDelegateClass.Create;
begin
  inherited Create;
  writeln('Creating ',ClassName);
end;

destructor TDelegateClass.Destroy;
begin
  writeln('Destroying ',ClassName);
  inherited Destroy;
end;

{ TMyClass }

constructor TMyClass.Create(obj: TDelegateClass);
begin
  inherited Create;
  FMyInterface := obj;
  writeln('Creating ',ClassName);
end;

destructor TMyClass.Destroy;
begin
  writeln('Destroying ',ClassName);
  inherited Destroy;
end;

{ TDelegateTest }

procedure TDelegateTest.DoRun;
var Intf: IMyInterface;
    Intf2: IMyInterface;
begin
   Intf := TMyClass.Create(TDelegateClass.Create);
   Intf2 := TDelegateClass.Create;
  // stop program loop
  Terminate;
end;

constructor TDelegateTest.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  StopOnException := True;
end;

destructor TDelegateTest.Destroy;
begin
  inherited Destroy;
end;

procedure TDelegateTest.WriteHelp;
begin
  { add your help code here }
  writeln('Usage: ', ExeName, ' -h');
end;

var
  Application: TDelegateTest;
begin
  Application := TDelegateTest.Create(nil);
  Application.Title := 'Interface Delegation Test';
  Application.Run;
  Application.Free;
end.

_______________________________________________
fpc-pascal maillist  -  fpc-pascal@lists.freepascal.org
http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-pascal