Home Mes Produits Delphi

Destructor sur un Record


Les Record ont bien évolué depuis Turbo Pascal ! alors qu'ils n'étaient que de simples types structurés à l'origine, ils sont maintenant capables de bien des choses puisque Delphi autorise l'ajout de méthodes "objet" aux records. Cela les fait un peu plus ressembler aux anciens "object" de Turbo Pascal, bien qu'ils ne supportent pas l'héritage.

L'article du jour est une petite astuce pour implémenter un destructor automatique sur les record. Ce n'est pas simple puisque les records n'acceptent pas les destructeurs d'une part, et que même si cela avait été le cas, il ne serait pas appelé automatiquement en fin de fonction.

type
  TMonRecord = record
    Stream: TStream;
  end;

procedure test;
var
  R: TMonRecord;
begin
  R.Stream := TStream.Create;
// je veux que le Stream de mon record soit libéré !
end;

Autant le dire de suite, la solution que je vous propose est assez technique, fiable, mais totalement ésotérique :)

Les Interfaces à la rescousse

Une des particularité des interfaces sous Delphi, c'est qu'elle sont automatiquement libérées quand elles sont hors de portée. Donc dans notre exemple ci-dessus, si R était une interface, elle serait libérée.
Mais il y a mieux, si R contient une interface, celle-ci est également libérée ! on peut donc astucieusement inclure une interface dans notre Record pour déclencher automatiquement un traitement.
J'ai d'ailleurs trouvé un article (en anglais) qui explique le principe juste ici.

Mais je suis aller un peu plus loin car si je ne voulais pas placer mon Record dans une Interface (qui serait détruite automatiquement), ce n'est pas pour en instancier une "dans" mon record. J'ai donc cherché à exploiter la solution de façon plus fine.

Rappels sur les interfaces

Toutes les interfaces publient au moins 3 méthodes, celles de IInterface :
type
  IInterface = interface
    ['{00000000-0000-0000-C000-000000000046}']
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

Ensuite, que se passe-t-il ? Et bien Delphi, ajoute un code automatique quand on manipule une variable de type Interface; la méthode _AddRef est appelée quand on assigne la variable, et la méthode _Release quand la variable n'est plus utile (variable locale en fin de procédure, ou variable quelconque qui reçoit la valeur "nil").

Et de fait, une Interface n'est autre qu'un tableau de méthodes; je pourrais la décrire sans le mot clé interface comme ceci :
 IUnknown = ^PUnknown;
 PUnknown = ^TUnknown;
 TUnknown = record
  QueryInterface:function(const Self:IUnknown; const IID:TGUID; out obj): Integer; stdcall;
  AddRef        :function(const Self:IUnknown): Integer; stdcall;
  Release       :function(const Self:IUnknown): Integer; stdcall;
 end;
Notez bien que IUnknown est un pointeur sur PUnknown qui est lui-même un pointeur sur TUnknown.

Ce qui nous intéresse ici c'est uniquement la fonction Release. Voici ce que cela pourrait donner:
type
  TMonRecord = record
  private
    PSelf     : Pointer;
    Release   : IUnknown;
    _Release  : function: Integer of object; stdcall;
  public
    Stream: TStream;
  end;

en déclarant mon record comme ceci, je lui ajoute 3 membres, soit la taille de IInterface...mais attendez, elle n'est pas correctement déclarée cette structure !? En effet, seule la méthode _Release correspond réellement à une Interface, mais en fait ça tombe bien car c'est la seule méthode que je veux exploiter. Elle n'a pas la même définition qu'au dessus en apparence, mais une procedure "of object" est simplement une procédure qui possède un paramètre implicite "Self"; les deux déclarations sont donc équivalentes.

Il manque aussi un petit quelque chose, car ma structure n'est pas initialisée:

type
  TMonRecord = record
  private
    PSelf     : Pointer;
    Release   : IUnknown;
    _Release  : function: Integer of object; stdcall;
    function DoRelease: Integer; stdcall;
  public
    Stream: TStream;
    procedure EnableARC;
  end;

procedure TMonRecord.EnableARC;
begin
  PSelf := @Self;
  Pointer(Release) := @PSelf;
  _Release := DoRelease;
end;

function TMonRecord.DoRelease;
begin
  Stream.Free;
  Result := 0;
end;

Whaouh ! c'est quoi ce montage ?

Reprenons dans l'ordre : 
PSelf := @Self
Nous l'avons dit, une Interface est un pointeur sur un pointer, voici le premier

Pointer(Release) := @PSelf
Voici le second, notez que l'interface "Release" est transtypée en Pointer pour ne SURTOUT PAS invoquer _AddRef qui n'est pas valide ici puisque son emplacement est utilisé justement pour stocker l'IUknown

_Release := DoRelease
et voilà notre fonction release qui est bien réelle, et qui pointe sur une méthode de notre objet qui fera office de destructor.

Démonstration :

program RecordARC;

{$APPTYPE CONSOLE}

type
  TMonObject = class
  private
    Name: string;
  public
    constructor Create(const AName: string);
    destructor Destroy; override;
  end;

constructor TMonObject.Create;
begin
  Name := AName;
  WriteLn('Creation de ', Name);
end;

destructor TMonObject.Destroy;
begin
  WriteLn('Destruction de ', Name);
end;

type
  TMonRecord = record
  private
    PSelf     : Pointer;
    Release   : IUnknown;
    _Release  : function: Integer of object; stdcall;
    function DoRelease: Integer; stdcall;
  public
    MonObject : TMonObject;
    procedure EnableARC;
  end;

procedure TMonRecord.EnableARC;
begin
  PSelf := @Self;
  Pointer(Release) := @PSelf;
  _Release := DoRelease;
end;

function TMonRecord.DoRelease;
begin
  MonObject.Free;
  Result := 0;
end;

procedure test1();
var
  R: TMonRecord;
begin
  WriteLn('TEST1 :');
  R.MonObject := TMonObject.Create('test1');
end;

procedure test2();
var
  R: TMonRecord;
begin
  WriteLn('TEST2 :');
  R.EnableARC;
  R.MonObject := TMonObject.Create('test2');
end;

begin
  test1();
  test2();
  WriteLn('DONE.');
  ReadLn;
end;

Si vous exécutez ce petit programme vous obtiendrez bel et bien
TEST1 :
Creation de test1
TEST2 :
Creation de test2
Destruction de test2
DONE.

Autre exemple

On m'a fait remarquer - à tord évidemment - que dans mon exemple on avait déjà un objet et que c'était stupide de le mettre dans un record. Mais l'objet de la démonstration n'était pas de libérer un objet, mais de déclencher automatiquement un destructeur de record. Voici donc un autre exemple peut-être plus explicite.

program Project1;
{$APPTYPE CONSOLE}
uses
  Winapi.Windows,
  System.SysUtils,
  System.DateUtils;
 
type
  TMonRecord = record
  private
    PSelf     : Pointer;
    Release   : IUnknown;
    _Release  : function: Integer of object; stdcall;
    function DoRelease: Integer; stdcall;
  public
    Name     : string;
    StartTime: TDateTime;
    procedure Start(const AName: string);
  end;

procedure TMonRecord.Start(const AName: string);
begin
  Name := AName;
  WriteLn('Start of ', Name);
  StartTime := Now();
  PSelf := @Self;
  Pointer(Release) := @PSelf;
  _Release := DoRelease;
end;

function TMonRecord.DoRelease;
begin
  WriteLn('End of ', Name, ' after ', MillisecondsBetween(StartTime, Now), 'ms');
  Result := 0;
end;

procedure test();
var
  R: TMonRecord;
  i: Integer;
begin
  R.Start('TEST');
  for i := 0 to 100 do
    Sleep(1);
end;

begin
  test();
  WriteLn('DONE.');
  ReadLn;
end.

Start of TEST
End of TEST after 194ms
DONE.

Complément d'enquête

Une chose amusante avec cette technique - que je n'utiliserais probablement pas réellement - c'est qu'elle fonctionne depuis l'introduction des Interface dans Delphi, ici sous Delphi 6

program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TLogger = record
    PSelf: Pointer;
    Release: IUnknown;
    _Release: function(var Sender): Integer; stdcall;
    Name: string;
    Time: TDateTime;
  end;

function DoRelease(var Sender): Integer; stdcall;
begin
  with TLogger(Sender) do
  begin
    WriteLn('End of ', Name, ' after ', (Now - Time) * 60 * 60 * 1000:0:2, 'ms');
  end;
end;

procedure Start(var Sender: TLogger; const AName: string);
begin
  Sender.Name := 'Test';
  Sender.Time := Now();
  Sender.PSelf := @Sender;
  Pointer(Sender.Release) := @Sender.PSelf;
  Sender._Release := DoRelease;
end;

procedure test;
var
  L: TLogger;
  i: Integer;
begin
  Start(L, 'Test');
  for i := 0 to 100 do
    Sleep(1);
end;

begin
  { TODO -oUser -cConsole Main : placez le code ici }
  test();
  ReadLn;
end.

En parlant de vieilles choses

Cette technique fonctionne également pour le type "object" à ne pas confondre avec la class TObject:
program Project1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TAutoFreeObject = object
  private
    PSelf: Pointer;
    IRelease: IUnknown;
    _Release: function: Integer of object; stdcall;
    function Release: Integer; stdcall;
  public
    constructor Create;
    destructor Destroy; virtual;
  end;

  TLogger = object(TAutoFreeObject)
  public
    Name: string;
    Time: TDateTime;
    constructor Create(const AName: string);
    destructor Destroy; virtual;
  end;


constructor TAutoFreeObject.Create;
begin
  PSelf := @Self;
  Pointer(IRelease) := @PSelf;
  _Release := Release;
end;

function TAutoFreeObject.Release: Integer;
begin
  Destroy;
  Result := 0;
end;

destructor TAutoFreeObject.Destroy;
begin
end;

constructor TLogger.Create(const AName: string);
begin
  inherited Create;
  Name := AName;
  Time := Now;
end;

destructor TLogger.Destroy;
begin
  WriteLn('End of ', Name, ' after ', (Now - Time) * 60 * 60 * 1000:0:2, 'ms');
end;


procedure test;
var
  L: TLogger;
  i: Integer;
begin
  L.Create('Test');
  for i := 0 to 100 do
    Sleep(1);
end;

begin
  { TODO -oUser -cConsole Main : placez le code ici }
  test();
  ReadLn;
end.

ATTENTION cependant, sur Delphi 6 je constate que cela ne fonctionne pas ! Mais sous Tokyo (Delphi 10.2) l'interface héritée est belle et bien détruite.
Date de dernière modification : 03/07/2017