Why does an instance of class(TInterfacedObject, IDropTarget) not auto free?

Question

I'm implementing my IDropTarget based on: How can I allow a form to accept file dropping without handling Windows messages?

The implementation by David works fine. however the IDropTarget (TInterfacedObject) object does not auto free, not even when set to 'nil'.

Part of the code is:

{ TDropTarget }
constructor TDropTarget.Create(AHandle: HWND; const ADragDrop: IDragDrop);
begin
  inherited Create;
  FHandle := AHandle;
  FDragDrop := ADragDrop;
  OleCheck(RegisterDragDrop(FHandle, Self));
  //_Release;
end;

destructor TDropTarget.Destroy;
begin
  MessageBox(0, 'TDropTarget.Destroy', '', MB_TASKMODAL);
  RevokeDragDrop(FHandle);
  inherited;
end;
...

procedure TForm1.FormShow(Sender: TObject);
begin
  Assert(Panel1.HandleAllocated);
  FDropTarget := TDropTarget.Create(Panel1.Handle, nil) as IDropTarget;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FDropTarget := nil; // This should free FDropTarget
end;

var
  NeedOleUninitialize: Boolean = False;

initialization
  NeedOleUninitialize := Succeeded(OleInitialize(nil));

finalization
  if (NeedOleUninitialize) then
    OleUninitialize;

end.

where FDropTarget: IDropTarget;.

When I click the button no MessageBox is shown and the object is not destroyed.

If I call _Release; as suggested here at the end of the constructor, FDropTarget is destroyed when I click the button or when the program terminates (I have doubts about this "solution").

If I omit RegisterDragDrop(FHandle, Self), then FDropTarget is destroyed as expected.

I think the reference counting is broken for some reason. I'm really confused. How can I make the TInterfacedObject free correctly?

EDIT:

Here is the complete code:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VirtualTrees, ExtCtrls, StdCtrls,
  ActiveX, ComObj;

type    
  TDropTarget = class(TInterfacedObject, IDropTarget)
  private
    FHandle: HWND;
    FDropAllowed: Boolean;
    function GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
    procedure SetEffect(var dwEffect: Integer);
    function DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult; stdcall;
    function DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
  public
    constructor Create(AHandle: HWND);
    destructor Destroy; override;
  end;

  TForm1 = class(TForm)
    Panel1: TPanel;
    VirtualStringTree1: TVirtualStringTree;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure VirtualStringTree1DragAllowed(Sender: TBaseVirtualTree;
      Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    FDropTarget: IDropTarget;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TDropTarget }

constructor TDropTarget.Create(AHandle: HWND);
begin
  inherited Create;
  FHandle := AHandle;
  OleCheck(RegisterDragDrop(FHandle, Self));
  //_Release;
end;

destructor TDropTarget.Destroy;
begin
  MessageBox(0, 'TDropTarget.Destroy', '', MB_TASKMODAL);
  RevokeDragDrop(FHandle);
  inherited;
end;

function TDropTarget.GetTreeFromDataObject(const DataObject: IDataObject): TBaseVirtualTree;
// Returns the owner/sender of the given data object by means of a special clipboard format
// or nil if the sender is in another process or no virtual tree at all.
var
  Medium: TStgMedium;
  Data: PVTReference;
  formatetcIn: TFormatEtc;
begin
  Result := nil;
  if Assigned(DataObject) then
  begin
    formatetcIn.cfFormat := CF_VTREFERENCE;
    formatetcIn.ptd := nil;
    formatetcIn.dwAspect := DVASPECT_CONTENT;
    formatetcIn.lindex := -1;
    formatetcIn.tymed := TYMED_ISTREAM or TYMED_HGLOBAL;
    if DataObject.GetData(formatetcIn, Medium) = S_OK then
    begin
      Data := GlobalLock(Medium.hGlobal);
      if Assigned(Data) then
      begin
        if Data.Process = GetCurrentProcessID then
          Result := Data.Tree;
        GlobalUnlock(Medium.hGlobal);
      end;
      ReleaseStgMedium(Medium);
    end;
  end;
end;

procedure TDropTarget.SetEffect(var dwEffect: Integer);
begin
  if FDropAllowed then begin
    dwEffect := DROPEFFECT_COPY;
  end else begin
    dwEffect := DROPEFFECT_NONE;
  end;
end;

function TDropTarget.DragEnter(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
  Tree: TBaseVirtualTree;
begin
  Result := S_OK;
  try
    Tree := GetTreeFromDataObject(dataObj);
    FDropAllowed := Assigned(Tree);
    SetEffect(dwEffect);
  except
    Result := E_UNEXPECTED;
  end;
end;

function TDropTarget.DragLeave: HResult;
begin
  Result := S_OK;
end;

function TDropTarget.DragOver(grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
begin
  Result := S_OK;
  try
    SetEffect(dwEffect);
  except
    Result := E_UNEXPECTED;
  end;
end;

function TDropTarget.Drop(const dataObj: IDataObject; grfKeyState: Integer; pt: TPoint; var dwEffect: Integer): HResult;
var
  Tree: TBaseVirtualTree;
begin
  Result := S_OK;
  try
    Tree := GetTreeFromDataObject(dataObj);
    FDropAllowed := Assigned(Tree);
    if FDropAllowed then
    begin
      Alert(Tree.Name);
    end;
  except
    Application.HandleException(Self);
  end;
end;

{----------------------------------------------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
  VirtualStringTree1.RootNodeCount := 10;
end;

procedure TForm1.VirtualStringTree1DragAllowed(Sender: TBaseVirtualTree;
  Node: PVirtualNode; Column: TColumnIndex; var Allowed: Boolean);
begin
  Allowed := True;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Assert(Panel1.HandleAllocated);
  FDropTarget := TDropTarget.Create(Panel1.Handle) as IDropTarget;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FDropTarget := nil; // This should free FDropTarget
end;

var
  NeedOleUninitialize: Boolean = False;

initialization
  NeedOleUninitialize := Succeeded(OleInitialize(nil));

finalization
  if (NeedOleUninitialize) then
    OleUninitialize;

end.

DFM:

object Form1: TForm1
  Left = 192
  Top = 114
  Width = 567
  Height = 268
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Shell Dlg 2'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object Panel1: TPanel
    Left = 368
    Top = 8
    Width = 185
    Height = 73
    Caption = 'Panel1'
    TabOrder = 0
  end
  object VirtualStringTree1: TVirtualStringTree
    Left = 8
    Top = 8
    Width = 200
    Height = 217
    Header.AutoSizeIndex = 0
    Header.Font.Charset = DEFAULT_CHARSET
    Header.Font.Color = clWindowText
    Header.Font.Height = -11
    Header.Font.Name = 'MS Shell Dlg 2'
    Header.Font.Style = []
    Header.MainColumn = -1
    Header.Options = [hoColumnResize, hoDrag]
    TabOrder = 1
    TreeOptions.SelectionOptions = [toMultiSelect]
    OnDragAllowed = VirtualStringTree1DragAllowed
    Columns = <>
  end
  object Button1: TButton
    Left = 280
    Top = 8
    Width = 75
    Height = 25
    Caption = 'Button1'
    TabOrder = 2
    OnClick = Button1Click
  end
end

Conclusion: From the docs:

RegisterDragDrop function also calls the IUnknown::AddRef method on the IDropTarget pointer

The code in the answer I linked was fixed.

Note that reference counting on TDropTarget is suppressed. That is because when RegisterDragDrop is called it increments the reference count. This creates a circular reference and this code to suppress reference counting breaks that. This means that you would use this class through a class variable rather than an interface variable, in order to avoid leaking.

Can you show a nicely cut down [mcve]. All behaves as expected when using the original code. — David Heffernan, Jan 19 '17 at 13:05
Where is your RevokeDragDrop(FHandle) ? the refcount of your class is 2 after these Line: FDropTarget := TDropTarget.Create(Panel1.Handle) as IDropTarget; — Fritzw, Jan 19 '17 at 13:05
@GolezTrol, David used an extra IDragDrop in his code for implementation. I did not b/c I don't need it. never mind, I'll remove the comment since it is not relevant to the problem. — zig, Jan 19 '17 at 13:10
@Fritzw, `RevokeDragDrop` is in the destructor of the class. — zig, Jan 19 '17 at 13:12
@DavidHeffernan, really the MCVE is your code. and only `FDropTarget := TDropTarget.Create(Panel1.Handle, nil) as IDropTarget` — zig, Jan 19 '17 at 13:15
There is the Problem, the destructor will not be called because the refcount is >0; So you should have a function for call revokeDragDrop from outside — Fritzw, Jan 19 '17 at 13:16
Can we have a [mcve] please. Why do we have to ask so many times, again and again. It takes you little effort to make one. Then we all have the same code. Then there's no speculation. We know how to do this. — David Heffernan, Jan 19 '17 at 13:16
The code is somewhere else. I'd have to try and re-create your code. Why should I do that. If you want help, why can't you do so. — David Heffernan, Jan 19 '17 at 13:29

Wosi · Accepted Answer · 2017-01-20T13:23:50.503

9

The call to RegisterDragDrop in TDragDrop.Create passes a counted reference to the instance of the new instance of TDragDrop. That increases its reference counter. The instruction FDragDrop := Nil decreases the reference counter but there is still a reference to the object living that prevents the object from destroying itself. You need to call RevokeDragDrop(FHandle) before you remove the last reference to that instance in order to get the reference counter down to zero.

In short: Calling RevokeDragDrop within the destructor is too late.

edited Jan 20 '17 at 13:23

answered Jan 19 '17 at 13:20

Wosi

41,986
17
75
82

Why should RegisterDragDrop increase the ref count? – zig Jan 19 '17 at 13:26
Because it is a Interface? – Fritzw Jan 19 '17 at 13:26
1

Ahhh, I see. the docs say: *"The RegisterDragDrop function also calls the IUnknown::AddRef method on the IDropTarget pointer."* Can I call the `_Release;` to reset the ref count? – zig Jan 19 '17 at 13:30
Let me see if I can fix the code at the other question. The code in my app is different in a subtle way. – David Heffernan Jan 19 '17 at 13:32
2

OK, I've done that now. This answer can be accepted. It would benefit from a link to the documentation that @zig found. – David Heffernan Jan 19 '17 at 13:38
Calling `RegisterDragDrop()` in the Drop object's constructor and `RevokeDragDrop()` in its destructor is just plain wrong to begin with. HWNDs created by VCL controls are not persistent, they can (and do) get recreated dynamically (potentially multiple times) during the app's lifetime. Only the controls know when that happens, the Drop object cannot. The *correct* solution is to subclass the Panel to create and register the Drop object whenever the Panel (re)creates its HWND, and unregister and release the Drop object whenever the Panel is about to destroy its HWND. – Remy Lebeau Jan 19 '17 at 20:55
1

@remy create the drop object when the window handle is created. Destroy the drop object when the window handle is destroyed. The drop object class is fine. It just needs to be tied to the window lifetime. – David Heffernan Jan 19 '17 at 22:23
1

Personally, I would (and do) create the drop object one time when the Form is created and keep a reference to it (refcnt 1), then register it whenever the Panel window is created (refcnt 2) and unregister it whenever the Panel window is destroyed (refcnt 1), and then finally release it (refcnt 0) when the Form is destroyed. – Remy Lebeau Jan 19 '17 at 22:56
@RemyLebeau, this could also be a good solution. thanks. in any case I do exactly what David wrote. "create the drop object when the window handle is created. Destroy the drop object when the window handle is destroyed." but your solution can be useful if one requires an interfaced object. – zig Jan 20 '17 at 10:35
@zig: `RegisterDragDrop()` expects an interfaced object. Even if you disable the object's reference counting, what I suggested would still work. – Remy Lebeau Jan 20 '17 at 17:48

Why does an instance of class(TInterfacedObject, IDropTarget) not auto free?

1 Answers1