Criar objetos dinâmicos com classe variável, onde a classe pode vir de um banco de dados ou arquivo de configuração.

E como fazer para esses objetos se autodestruírem sem causar memory leaks. Como reduzir o acoplamento em ambientes não OO altamente acoplados.

Nesta dica vamos ver quatro assuntos distintos, porém correlacionados:

  1. Interfaces e como usá-las evitando memory leaks.
  2. O tipo TClass e seus semelhantes, o que são e para que servem
  3. Como instanciar e manipular objetos dos quais você não sabe a classe. Isto envolve registrar a classe com RegisterClass e achá-la com FindClass
  4. A maneira certa de usar Agregates, delegates etc. sem causar memory leak.

Interfaces

De acordo com a Embarcadero, interfaces são definidas como um “contrato” entre duas partes, um padrão de encaixe. Por exemplo, uma placa de vídeo para se conectar numa placa mãe com slot pciXpress deve seguir esse padrão de pinagem.

Na prática, interfaces são como classes (só parecem), porém todos os métodos são públicos e as mesmas não tem implementação.

Na verdade, todas as classes tem uma interface implícita, que é o conjunto de métodos públicos da mesma. Se uma classe tem o método público function Mostrar(msg:string) então esse método faz parte da interface dessa classe mesmo que ela não implemente nenhuma.

Usando interfaces podemos intercambiar objetos que implementam a mesma interface, mesmo que sejam de linhagens diferentes.

Por exemplo, se duas classes totalmente diferentes (dois forms, para exemplificar), implementam a mesma interface, mas não são irmãs, nem mãe-filha e não tem nenhum grau de parentesco, uma variável do tipo dessa interface pode conter instâncias, tanto de uma form como de outra.

Isso é essencial quando precisamos instanciar e abrir um form, mas não sabemos a princípio qual o tipo, porque este vai ser definido em runtime. Então, um factorymethod ou um abstract factory poderia instanciar esse form para nós e ele poderia ser “acondicionada” em uma variável do tipo dessa interface.

Por exemplo, imagine uma interface IProcura:


IProcura = interface
 ['{05A634F2-B8CD-4DFD-8447-59B77DE7682F}']
     Procedure Procura(valor: variant); 
 End;

Agora imagine que você tem um formulário de procura diferente para cada form do seu projeto: ProduraCliente, ProcuraFornecedor, ProcuraProduto etc. Se todos esses forms, embora diferentes entre si, implementassem a interface IProcura e o método Procura, qualquer uma delas poderia ser instanciada numa variável:


Var Proc: IProcura;

Então estariam corretos:


Proc:= TProcuraCliente.create(nil);
Proc:= TProcuraFornecedor.create(nil);
Proc:= TProcuraProduto.create(nil);

Interfaces também podem suprir a necessidade de herança múltipla. Mas não queremos nos delongar na questão das interfaces. Então sugiro a leitura da ClubeDelphi 74 e 75, e estudar livros e sites de POO a respeito.

Um fato curioso é que na revista ClubeDelphi 74 diz que você não precisa dar um free num objeto que implementa uma interface (se você instanciá-lo na variável de interface, claro), pois a interface é liberada da memória automaticamente.

Isso é verdade SE E SOMENTE SE a sua classe for descendente de TInterfacedObject. Isso porque essas classes implementam a interface básica IInterface, cujos métodos são:


function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;

Estas classes guardam uma contagem de referências à uma instância da interface, e o método _Release verifica se a contagem de referências atinge zero.

Se atingir zero ele dá o famoso e conhecido Destroy. Definimos como referências o número de usos ou menções a uma instância de um objeto que implementa uma interface na memória, ou seja, o número de variáveis que apontam para ele.

Por exemplo, se uma variável aponta para uma instância de um objeto, temos uma referência. Se duas variáveis e um parâmetro de método por valor apontam para o mesmo objeto, temos três referências, embora o objeto seja o mesmo.

Se damos o comando Proc:=TProcuraCliente.create(nil); e depois Proc:=TProcuraCliente.create(nil); novamente, o primeiro objeto instanciado perde sua referência, porque não tem ninguém mais apontando para ele, uma vez que o segundo objeto sobrescreveu a variavel, que agora aponta para o segundo.

Cada vez que um objeto implementa uma interface, perde-se a referência, e é executado o método _release (se atribuir nil a uma variável interface, por exemplo, ela vai apontar para um endereço nulo de memória e não mais para a instância do objeto, que chamará o método _release).

Veja a implementação de _release no Delphi 7:


TInterfacedObject:
   function TInterfacedObject._Release: Integer;
   begin
Result := InterlockedDecrement(FRefCount); //decrementa de maneira thread-safe
if Result = 0 then 
              Destroy; //manda bala no objeto
   end;

Mas porque eu disse que isso só ocorre SE E SOMENTE SE a sua classe for descendente de TInterfacedObject? É porque essa classe dá um free quando FrefCount chega a zero, mas a classe TInterfacedPersistent não, como mostra sua implementação:


function TInterfacedPersistent._Release: Integer;
 begin
if FOwnerInterface <> nil then
            Result := FOwnerInterface._Release
     else     
            Result := -1;
 end; 

Na classe Tcomponent, que láno fundo herda de Tpersistent, também há uma implementação de_Release, pois TComponent implementa IInterface, mas também não dá o free:


function TComponent._Release: Integer;
begin
if FVCLComObject = nil then
          Result := -1 // -1 indicates no reference counting is taking place
else
          Result := IVCLComObject(FVCLComObject)._Release;

end;

Está Errado? Não sei dizer se está errado, (eu nunca vi uma situação em que esses métodos retornassem algo diferente de -1, nem o FOwnerInterface ou o FVCLComObject <. de nil) mas se você usar o fastmm4, verá que há um memory leak se você instanciar objetos dessas classes em uma interface e não destruí-los. Já os objetos de classes derivadas de TInterfacedObject você não precisa destruir.

Faça o teste: baixe o FastMM4, ajuste as opções de Report de Memory Leak e inclua a unit Fastmm4 como primeira unit do seu DPR e sete variáveis:


FullDebugModeScanMemoryPoolBeforeEveryOperation:= True;
SuppressMessageBoxes:=False;

Logo depois do begin do seu DPR, ficando assim:


program
Project1;

uses
   FastMM4,
   Forms,
   Unit1 in 'Unit1.pas' {Form1};

{$R *.res}

begin 
   FullDebugModeScanMemoryPoolBeforeEveryOperation := True;
   SuppressMessageBoxes:=False;
   Application.Initialize;
   Application.CreateForm(TForm1,Form1);
   Application.Run;
end.

Eu criei a interface Iteste e três classes que a implementam: uma filha de TInterfacedObject, uma filha de TinterfacedPersistent e outra filha de TComponent:


ITeste = interface(IInterface)
['{B0653AC1-B7A2-4E41-9DA3-B8E5C3480AE7}']
   procedure Testar;
end;

TClassTeste = class(TInterfacedObject, ITeste)
public
   procedure Testar;
end;

TPersistentTeste = class(TInterfacedPersistent, Iteste)
public
   procedure Testar;
end;

TComponentTeste = class(TComponent, Iteste)
public
   procedure Testar;
end;

Além disso criei três botões, um para instanciar cada uma delas e executar o método Testar:


{ TClassTeste }
procedure TClassTeste.Testar;
begin
   ShowMessage('Testando Classe teste');
end;

{ TPersistentTeste }
procedure TPersistentTeste.Testar;
begin
   ShowMessage('Testando Persistent teste');
end;

{ TComponentTeste }
procedure TComponentTeste.Testar;
begin
   ShowMessage('Testando Componente teste');
end;

procedure TForm1.btInterfaceObjectClick(Sender: TObject);
var
   teste: ITeste;
begin
   teste := TClassTeste.create;
   teste.Testar;
end;

procedure TForm1.btInterfacePersistentClick(Sender: TObject);
var
   teste: ITeste;
begin
   teste := TPersistentTeste.create;
   teste.Testar;
end;

procedure
TForm1.btComponentClick(Sender: TObject);
var
   teste: ITeste;
begin
   teste := TComponentTeste.create(nil);
   teste.Testar;
end;

Clique no primeiro botão e feche o programa. Repare que não teve memory leak, pois o objeto da classe TClassTeste, ao perder sua referência no fechamento do programa, chama _release e dá um Destroy em si mesmo, visto que a contagem de referências atingiu zero. Porém, se você repetir o mesmo teste com os outros botões verá que TPersistent, TInterfacedPersistent e TComponent causam memory leaks.

Se sua classe é filha ou de alguma forma é descendente de TComponent, Tpersistent ou TInterfacedPersistent, você pode solucionar esse problema implementando e sobrecarregando esses dois métodos de IInterface, seguindo o exemplo da classe TInterfacedObject:


function _AddRef: Integer; stdcall; 
function _Release: Integer; stdcall;

O Código da nossa unit até aqui é o seguinte:


unit Unit1;
interface
uses
     Windows, Messages, SysUtils, Variants, Classes, Graphics, 
     Controls, Forms, Dialogs, StdCtrls;

type
     TForm1 = class(TForm)
     btInterfaceObject: TButton;
     btInterfacePersistent: TButton;
     btComponent: TButton;
     procedure btInterfaceObjectClick(Sender: TObject);
     procedure btInterfacePersistentClick(Sender: TObject);
     procedure btComponentClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

ITeste = interface(IInterface)
['{B0653AC1-B7A2-4E41-9DA3-B8E5C3480AE7}']
 procedure Testar;

end;

TClassTeste = class(TInterfacedObject, ITeste)
public
 procedure Testar;
end;

TPersistentTeste = class(TInterfacedPersistent, Iteste)
public
 procedure Testar;
end;

TComponentTeste = class(TComponent, Iteste)
public
 procedure Testar;
end;

var

Form1: TForm1;

implementation

{$R *.dfm}

{TClassTeste }

procedure TClassTeste.Testar;
begin
 ShowMessage('Testando Classe teste');
end;

{TPersistentTeste }

procedure TPersistentTeste.Testar;
begin
 ShowMessage('Testando Persistent teste');
end;


{TComponentTeste }

procedure TComponentTeste.Testar;
begin
 ShowMessage('Testando Componente teste');
end;


procedure TForm1.btInterfaceObjectClick(Sender: TObject);
var
 teste: ITeste;
begin
 teste := TClassTeste.create;
 teste.Testar;
end;


procedure TForm1.btInterfacePersistentClick(Sender: TObject);
var
 teste: ITeste;
begin
 teste := TPersistentTeste.create;
 teste.Testar;
end;


procedure TForm1.btComponentClick(Sender: TObject);
var
     teste: ITeste;
begin
     teste := TComponentTeste.create(nil);
     teste.Testar;
end;

end.

Já o DFM fica da seguinte forma:


object Form1: TForm1
  Left = 419
  Top = 318
  Width = 142
  Height = 151
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object btInterfaceObject: TButton
     Left = 8
     Top = 16
     Width = 121
     Height = 25
     Caption = 'TInterfacedObject'
     TabOrder = 0
     OnClick = btInterfaceObjectClick
  end

  object btInterfacePersistent: TButton
     Left = 8
     Top = 48
     Width = 121
     Height = 25
     Caption = 'TInterfacedPersistent'
     TabOrder = 1
     OnClick = btInterfacePersistentClick
  end

  object btComponent: TButton
     Left = 8
     Top = 80
     Width = 121
     Height = 25
     Caption = 'TComponent'
     TabOrder = 2
     OnClick = btComponentClick
  end
end

Agora vamos sobrecarregar os métodos das nossas classe filhas de TComponent e TInterfacedPersistent:


function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;

Você precisará também implementar um FRefCount igual ao TInterfacedObject. Mas como fazer isso sem alterar o result e seguindo o exemplo de TInterfacedObject? É simples, e o código final do teste, com as classes filhas de TInterfacedPersistent e TInterfacedObject vai abaixo. Criei uma função chamada showmessage que escreve as mensagens num memo, ao invés de mostrar message boxes:


unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes,
 Graphics, Controls, Forms, Dialogs, StdCtrls;
type
 TForm1 = class(TForm)
   btInterfaceObject: TButton;
   btInterfacePersistent: TButton;
   btComponent: TButton;
   btDelegaObj: TButton;
   Memo1: TMemo;
   procedure btInterfaceObjectClick(Sender: TObject);
   procedure btInterfacePersistentClick(Sender: TObject);
   procedure btComponentClick(Sender: TObject);
   procedure btDelegaObjClick(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

 ITeste = interface(IInterface)
 ['{B0653AC1-B7A2-4E41-9DA3-B8E5C3480AE7}']
   procedure Testar;
 end;

 TClassTeste = class(TInterfacedObject, ITeste)
 public
   procedure Testar;
 end;

 TPersistentTeste = class(TInterfacedPersistent, Iteste)
 private
   FRefCount: Integer;
 public
   procedure Testar;
   function _AddRef: Integer; stdcall;
   function _Release: Integer; stdcall;
 end;

 TComponentTeste = class(TComponent, Iteste)
 private
   FRefCount: Integer;
 public
   procedure Testar;
   function _AddRef: Integer; stdcall;
   function _Release: Integer; stdcall;
 end;

 TClasseAgregada = class(TAggregatedObject, ITeste)
 private
   FITeste: ITeste;
   //FITeste: TClassTeste;
   //FITeste: TPersistentTeste;
   //FITeste: TComponentTeste;
 public
   procedure Testar;
   constructor Create;
   property Teste: ITeste read FITeste write FITeste implements Iteste;
 end;

var
 Form1: TForm1;

 //apenas para sobrescrever a original, melhor mostrar num memo 
 /do que um monte de janelinhas
 procedure ShowMessage(msg: string);
implementation

 procedure ShowMessage(msg: string);
 begin
   Form1.Memo1.Lines.Add(msg);
 end;

{$R *.dfm}

{ TClassTeste }

procedure TClassTeste.Testar;
begin
 ShowMessage('Testando Classe teste');
end;

{ TPersistentTeste }
procedure TPersistentTeste.Testar;
begin
 ShowMessage('Testando Persistent teste');
end;

function TPersistentTeste._AddRef: Integer;
begin
 Result := inherited _AddRef;
 InterlockedIncrement(FRefCount);
 //ShowMessage('TPersistentTeste._AddRef: ' + IntToStr(Result)+ 
 // ' Contagem de referências: ' + IntToStr(FRefCount));
end;

function TPersistentTeste._Release: Integer;
begin
 Result := inherited _Release;
 //ShowMessage('TPersistentTeste._Release: ' + IntToStr(Result)+ 
 //' Contagem de referências: ' + IntToStr(FRefCount));
 InterlockedDecrement(FRefCount);
 if FRefCount <=0 then
   Free;
end;

{ TComponentTeste }
procedure TComponentTeste.Testar;
begin
 ShowMessage('Testando Componente teste');
end;

function TComponentTeste._AddRef: Integer;
begin
 Result := inherited _AddRef;
 InterlockedIncrement(FRefCount);
 //ShowMessage('TComponentTeste._AddRef: ' 
 //+ IntToStr(Result)+ ' Contagem de referências: ' + IntToStr(FRefCount));
end;

function TComponentTeste._Release: Integer;
begin
 Result := inherited _Release;
 //ShowMessage('TComponentTeste._Release: ' 
 //+ IntToStr(Result)+ ' Contagem de referências: ' + IntToStr(FRefCount));
 InterlockedDecrement(FRefCount);
 if FRefCount <=0 then
   Free;
end;

procedure TForm1.btInterfaceObjectClick(Sender: TObject);
var
 teste: ITeste;
 Multiplasreferências: array[1..10] of ITeste;
 i: Integer;
begin
 teste := TClassTeste.create;
 teste.Testar;

 for i := 1 to 10 do
 begin
   Multiplasreferências[i] := teste;
 end;
 for i := 1 to 10 do
 begin
   Multiplasreferências[i].Testar;
 end;
end;

procedure TForm1.btInterfacePersistentClick(Sender: TObject);
var
 teste: ITeste;
 Multiplasreferências: array[1..10] of ITeste;
 i: Integer;
begin
 teste := TPersistentTeste.create;
 teste.Testar;

 for i := 1 to 10 do
 begin
   Multiplasreferências[i] := teste;
 end;
 for i := 1 to 10 do
 begin
   Multiplasreferências[i].Testar;
 end;
end;

procedure TForm1.btComponentClick(Sender: TObject);
var
 teste: ITeste;
 Multiplasreferências: array[1..10] of ITeste;
 i: Integer;
begin
 teste := TComponentTeste.create(nil);
 teste.Testar;

 for i := 1 to 10 do
 begin
   Multiplasreferências[i] := teste;
 end;
 for i := 1 to 10 do
 begin
   Multiplasreferências[i].Testar;
 end;
end;

procedure TForm1.btDelegaObjClick(Sender: TObject);
var
 Teste:  TClasseAgregada;
 Multiplasreferências: array[1..10] of ITeste;
 i: Integer;
begin
 teste := TClasseAgregada.create;
 Teste.Testar;
 for i := 1 to 10 do
 begin
   Multiplasreferências[i] := teste;
 end;
 for i := 1 to 10 do
 begin
   Multiplasreferências[i].Testar;
 end;
 Teste.Free;
end;

constructor TClasseAgregada.Create;
begin
 FITeste := TClassTeste.Create;
 inherited Create(FITeste);
end;

procedure TClasseAgregada.Testar;
begin
 FITeste.Testar;
 ShowMessage('TClasseAgregada  - teste');
end;
end.

E o código de DFM ficou dessa forma:


object Form1: TForm1
 Left = 133
 Top = 318
 Width = 590
 Height = 321
 Caption = 'Form1'
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 PixelsPerInch = 96
 TextHeight = 13
 object btInterfaceObject: TButton
   Left = 8
   Top = 16
   Width = 121
   Height = 25
   Caption = 'TInterfacedObject'
   TabOrder = 0
   OnClick = btInterfaceObjectClick
 end
 object btInterfacePersistent: TButton
   Left = 8
   Top = 48
   Width = 121
   Height = 25
   Caption = 'TInterfacedPersistent'
   TabOrder = 1
   OnClick = btInterfacePersistentClick
 end
 object btComponent: TButton
   Left = 8
   Top = 80
   Width = 121
   Height = 25
   Caption = 'TComponent'
   TabOrder = 2
   OnClick = btComponentClick
 end
 object btDelegaObj: TButton
   Left = 8
   Top = 112
   Width = 121
   Height = 25
   Caption = 'Delegação TObject'
   TabOrder = 3
   OnClick = btDelegaObjClick
 end
 object Memo1: TMemo
   Left = 144
   Top = 13
   Width = 417
   Height = 273
   ScrollBars = ssVertical
   TabOrder = 4
 end
end

Funciona e não altera a funcionalidade nem os resultados das nossas classes e interfaces e nada de Memory Leak!

Agora você pode se perguntar: "Por quê de tudo isso?" Simples, se você quer que um método ou um objeto receba como parâmetro outro objeto, porém não quer especificar que objeto é esse, não quer engessar, mas quer deixar flexível, então você deverá usar interfaces, certo?

Contudo, uma variável do tipo interface, embora possa conter qualquer objeto que a implemente, não tem conhecimento de como destruí-la, certo?

Você não pode dizer Fteste: Iteste; Fteste := TTeste.create() e depois dar um FTeste.Destroy simplesmente porque o método Destroy não faz parte da interface. Você quer é não tem a responsabilidade nem de construir o objeto, delegando essa responsabilidade a um factory method, muito menos ter a responsabilidade de destruí-lo. Então um objeto que implementa uma interface deve saber destruir-se por si mesmo, senão houver nenhuma referência para ele.

"Bom, o TInterfacedObject já se destrói sozinho", você poderia dizer. Mas o TInterfacedPersistent e o TComponent não. E para quê eu preciso disso?

Um dos objetivos desse artigo é criar um Abstract Factory rústico usando o RegisterClass do Delphi. Esse método público estático registra numa lista interna do Delphi referências de classes. Depois você pode encontrar essa classe com o método FindClass. Não são referências a objetos instanciados, mas são referências a metadata de classes. Ou seja, você pode referenciar classes por seu nome, ou por uma variável, e não pela classe em si. Você pode criar um objeto sem saber qual é a sua classe ou mudar sua classe em runtime.

E se você quiser instanciar uma classe, por exemplo um form em uma variável do tipo interface, através de um abstractfactory ou através de uma classe registrada do Delphi, com FindClass e RegisterClass, você simplesmente não pode chamar o método destroy ou free, porque ele não existe na interface.

Você poderia fazer um typecast para a classe desejada, ou para object e dar um free, mas normalmente você desconhece a classe a qual tem de fazer typecast, e também isso pode resultar em vários access violation na hora de referenciar as interfaces, visto que elas executam o _Release de um objeto que não existe mais.

Então recapitulando:

  • Existe o tipo TClass, que é uma referência a uma classe (não objeto) do tipo TObject.
  • Existe o tipo TInterfacedClass, que é uma referência a uma classe TInterfacedObject.
  • Existe o tipo TPersistentClass que é uma referência a classe TPersistent,
  • Existe TComponentClass, TFormClass, mas não existe nenhum TInterfacedPersistentClass.
  • E pra que eu preciso de um TInterfacedPersistent e não posso usar um TInterfacedObject? Ou mesmo TObjectnormal?

Precisamos que seja interfaced para trabalhar com interfaces e queremos que nossos objetos sejam liberados automaticamente sem memory leak. Além disso, precisamos que seja descendente de TPersistent porque o método RegisterClass só registra descendentes de TPersistent. Então, como primeiro passo é declarar na sua biblioteca de classes:


TInterfacedPersistentClass = class of TInterfacedPersistent;

Cenário: Imagine que você tem um form de produtos e uma de consulta (TConsultaPro). Porém essas duas forms, da maneira como foram feitas estão engessadas e são usadas no sistema inteiro: nada pode ser alterado nelas ou em sua hierarquia, e não podemos criar descendentes das mesmas. Mas você precisa criar outras classes de consulta de produtos, clientes, fornecedores, pedidos etc., que podem ser ou não descendentes de TConsultaPro e podem ser forms ou classes que chamam forms.

A unit1 é a unit principal do nosso programa, que é o nosso cadastro de produtos:


//esta seria a unit principal do projeto

unit Unit1;

interface

uses
 Controls,
 Forms,
 Unit3,  //esta é a biblioteca onde se encontra a interface
 Classes,
 StdCtrls;

type
 TfrmPrincipal = class(TForm)
   btAbrir: TButton;
   procedure btAbrirClick(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
  iIntf: IFrmConsultaPro;  //A interface

end;

var
 frmPrincipal: TfrmPrincipal;

implementation

{$R *.dfm}

procedure TfrmPrincipal.btAbrirClick(Sender: TObject);
var
 NumPro: string;
 clsClasse:  TInterfacedPersistentClass;
 iIntf:  IFrmConsultaPro;
begin
 NumPro := '123456';
 clsClasse := TInterfacedPersistentClass(FindClass('TFConsultaProFactory'));
 if (clsClasse <> nil) then
 begin
   iIntf := ((clsClasse.Create) as IFrmConsultaPro);
   if iIntf <> nil then
   begin
       iIntf.ConsultaPro(NumPro);
   end;
   //ma que beleza hein!
 end;
end;
end.

O DFM fica da seguinte forma:


object frmPrincipal: TfrmPrincipal
 Left = 460
 Top = 469
 Width = 288
 Height = 137
 Caption = 'Form Principal'
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 PixelsPerInch = 96
 TextHeight = 13
 object btAbrir: TButton
   Left = 88
   Top = 64
   Width = 105
   Height = 25
   Caption = 'Abrir a outra Form'
   TabOrder = 0
   OnClick = btAbrirClick
 end
end

A unit2 é a unit que tem a nossa classe TConsultaPro que não pode ser mexida:


//Unit de uma form do projeto totalmente desconhecida e que pode ser chamada
//de varios pontos do projeto ou substituida na "cara de Pau" por outra
//que implemente a mesma interface

unit Unit2;

interface

uses
 Windows,
 Controls,
 Forms,
 Dialogs,
 Unit3, //unit da interface
 SysUtils,
 Classes, StdCtrls;

type
 TFConsultaPro = class(TForm)
   edt_Produto: TEdit;
   Label1: TLabel;
   procedure edt_ProdutoKeyPress(Sender: TObject; var Key: Char);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
 private
   { Private declarations }
 public

 end;

implementation

{$R *.dfm}

{ TFConsultaPro } 
procedure TFConsultaPro.edt_ProdutoKeyPress(Sender: TObject;   var Key: Char);
begin
 ShowMessage('Você consultou o produto: ' + edt_Produto.Text);
end;

procedure TFConsultaPro.FormClose(Sender: TObject;   var Action: TCloseAction);
begin
 Release;     
end;

end.

O seu DFM vai ficar da seguinte forma:


object FConsultaPro: TFConsultaPro
 Left = 346
 Top = 305
 Width = 331
 Height = 166
 Caption = 'Consultar Produto'
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 OnClose = FormClose
 PixelsPerInch = 96
 TextHeight = 13
 object Label1: TLabel
   Left = 96
   Top = 32
   Width = 96
   Height = 13
   Caption = 'Produto Consultado:'
 end
 object edt_Produto: TEdit
   Left = 96
   Top = 48
   Width = 121
   Height = 21
   TabOrder = 0
   OnKeyPress = edt_ProdutoKeyPress
 end
end

Vamos criar nossa interface conforme a unit 3, que é a nossa unit de "biblioteca":


//unit com os tipos, classes e interfaces usadas no sistema
unit Unit3;
interface

uses
 Classes;

type
 IFrmConsultaPro = interface(IInterface)
 ['{E054C396-7551-4B79-B439-A3130B25C79E}']
   procedure ConsultaPro(NumProd: string); stdcall;
 end;
 //Um tipo de referência de classe, para podermos encontrar e instanciar um
 //objeto de uma classe e unit desconhecida pelo seu nome (string) de forma
 //que ele seja uma classe interfaceada (que implemente IInterface)
 //é uma maneira "rustica" de se fazer um factoy method
 //a propria classe a ser registrada é uma factory que so serve para instanciar
 //um objeto da classe TFConsultaPro (form que consulta produto) quando
 //se executa o método  ConsultaPro. Optei por usar uma factory que
 //implementasse a interfac, mas a propria form poderia implementa - la
 //assim eu criaria diretamente a form e não o factory.
 //optei por criar esse factory para exemplificar as vezes que você não
 //pode mexer em nada ou quase nada na form, não podendo mexer por exemplo
 //na sua linhagem.
 //faz de conta que a TFConsultaPro é uma form legada, usada no sistema
 //inteiro e que vamos fazer de tudo para não mexer nela.
 //Até mesmo mantivemos a regra de negócio no evento do edit,
 //para demonstrar como aos poucos podemos melhorar uma programação altamente
 //acoplada, totalmente estruturada ou orientada a evento e diminuir o
 //acoplamento sem ser muito traumatizante.

 TInterfacedPersistentClass = class of TInterfacedPersistent;

implementation

end.

A Unit uFactory possui a nossa classe factory e é onde registramos com RegisterClass para ser encontrada com FindClass:


unit uFactory;

interface

uses
   Windows,
   Classes,
   Unit2,
   Unit3;

type
 TFConsultaProFactory = class(TInterfacedPersistent,  IFrmConsultaPro)
 private
   FRefCount: Integer;
 published
   procedure ConsultaPro(NumProd: string);
stdcall;

   //métodos de IInterface
   function _AddRef: Integer; stdcall;
   function _Release: Integer; stdcall;
 end;

implementation

procedure TFConsultaProFactory.ConsultaPro(NumProd: string);
var
 Enter: Char;
begin
 Enter := #13;
 with TFConsultaPro.Create(nil) do
 begin
   edt_Produto.Text:=NumProd;
   edt_Produto.OnKeyPress(edt_Produto,
Enter);
   ShowModal;
 end;
end;

function TFConsultaProFactory._AddRef: Integer;
begin
 Result := inherited  _AddRef;
 InterlockedIncrement(FRefCount);
end;

function TFConsultaProFactory._Release: Integer;
begin
 Result := inherited  _Release;
 InterlockedDecrement(FRefCount);
 if FRefCount <= 0 then
   Free;
end;

initialization

 //aqui eu registro minha classe factory (poderia ter registrado a form) para
 //que ela possa ser "encontrada" pelo dD declarada no uses.

 RegisterClass(TFConsultaProFactory);

 //repare que com isso podemos instanciar objetos atraves do nome da classe
 //podendo armazenar os nomes das classes que queremos instanciar em 
 //arquivos de configuração, bancos de dados etc.

end

Repare que no exemplo registramos uma classe que possui um método para instanciar o form. Assim essa classe teria o FactoryMethod da form, mas o registerClass e FindClass seria o FactoryMethod da nossa classe. Fizemos assim apenas para ilustrar a situação de um form feito por outra pessoa que você não pode mexer nem na unit. E num contexto que não era orientado a objeto, mas está em migração. Nada impede de fazer com que o próprio form implemente a interface IFrmConsultaPro, o método ConsultaPro e que o próprio form seja registrado com registerClass. Mas o release deveria ser automático, ou deveria-se implementar os métodos _AddRef e _Release.

Usando essas técnicas com criatividade você pode criar um ultra abstract factory que cria qualquer componente através de uma string, podendo permitir alterações em runtime, customizadas pelo cliente em vários pontos do seu software. Também poderá ter uma lista global de objetos criados e referências num objeto singleton para criar seu próprio garbage collector ou tirar estatísticas (bastando usar as interfaces e implementar essas alterações necessárias em _AddRef e _Release).

Com isso o memory leak não te pega mais e você pode destruir sem dó qualquer resquício de objeto que possa ficar na memória.