Memory Leaks, Interfaces, Agregates e RegisterClass

Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Para efetuar o download você precisa estar logado. Clique aqui para efetuar o login
Confirmar voto
0
 (1)  (0)

Como criar um objeto sem saber a classe, sabendo apenas o nome da classe como string. 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 auto - destruirem sem causar memory leaks. Como reduzir o acoplamento em ambientes não OO altamente acoplados.

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.

 
Você precisa estar logado para dar um feedback. Clique aqui para efetuar o login
Receba nossas novidades
Ficou com alguma dúvida?