[Resolvido] Memory Leaks, Interfaces, Agregates e RegisterClass

vitor^_^ · Maio 4, 2009

Memory Leaks, Interfaces, Agregates e RegisterClass

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.

Nesta dica vamos ver 3 assuntos distintos, porem 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 Acha-la com FindClass

4) A maneira certa de se usar Agregates, delegates etc sem causar memory leak.

Vamos falar agora sobre Interfaces.

Primeiro de tudo, até hoje, o melhor material que eu já vi sobre interfaces no Delphi é este aqui:

http://edn.embarcadero.com/article/30125

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, pelo amor de Deus), porem todos os métodos são públicos e ela 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 nós podemos intercambiar objetos que implementam a mesma interface, mesmo que sejam de linhagens diferentes. Por exemplo, se duas classes totalmente diferentes (duas forms, para exemplificar), implementam a mesma interface, mas não são irmãs, nem mãe-filha e não tem nenhum gral de parentesco, uma variável do tipo dessa interface pode conter instancias tanto de uma form como de outra.

Isso é essencial quando precisamos instanciar e abrir uma form, mas não sabemos a princípio qual o tipo, porque este vai ser definido em runtime. Então um factory method ou um abstract factory poderia instanciar essa form para nós e ela 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 todas essas 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 Clube Delphi 74 e 75, e estudar livros e sites de POO a respeito.

Um fato curioso é que na revista clube delphi 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 numero de usos ou menções a uma instancia 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 3 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 que implementa uma interface é De-referênciado, ou seja perde a referência, é 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, veja sua implementação:

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

Na classe Tcomponent, que laaaaaa 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, 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 as 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 3 classes que a implementam, uma filha de TInterfacedObject, uma filha de TinterfacedPersistent e outra filha de TComponent:

ITeste = interface(IInterface)
	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;

e criei 3 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. Reparou que não teve memory leak? Isso porque 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. Porem, 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 como solucionar esse problema?

Simples: implemente e sobrecarregue esses dois métodos:

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

de IInterface seguindo o exemplo da classe TInterfacedObject.

O Código da nossa unit até aqui:

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)
	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.

O DFM:

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

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

das nossas classe filhas de TComponent eTInterfacedPersistent:

Você precisará também de implementar um FRefCount igual ao TInterfacedObject.

Mas como fazer isso sem alterar o result e seguindo o exemplo de TInterfacedObject? Simples Assim:

O código final do teste, com classes filhas de TInterfacedPersistent e TInterfacedObject vai abaixo, criei uma função chamada showmessage que escreve as mensagens num memo, ao invez de mostrar messageboxes. Melhor para testar:

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.

o DFM:

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, não altera a funcionalidade nem os resultados das nossas classes e interfaces e.... Nada de Memory Leak!

Agora você pode me perguntar: "Por quê de tudo isso?" Simples, se você quer que um método ou um objeto receba como parâmetro um 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? Porem uma variável do tipo interface, embora possa conter qualquer objeto que implemente esta interface, não tem conhecimento de como destruí-lo, 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 ter 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, se nã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 instânciados, são referências a metadata de classes. Ou seja, você pode referênciar classes por seu nome, ou por uma variavel, 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 uma 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 acces violation na hora de dereferênciar as interfaces, visto que elas executam o _Release de um objeto que não existe mais.

Então vamos lá! já saímos do assunto "1", agora estamos no "2" .

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, por que não posso usar um TInterfacedObject? Ou mesmo TObject normal?

Precisamos que seja interfaced porque vamos trabalhar com interfaces e queremos que nossos objetos sejam liberados automaticamente sem memory leak. E precisamos que seja descentente de TPersistent porque o método RegisterClass só registra descendentes de TPersistent. Então, o primeiro de tudo é, na sua biblioteca de classes, declare:

TInterfacedPersistentClass = class of TInterfacedPersistent;

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

A unit1 é a unit principal do nosso programa. É 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:

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 que não pode ser mechida, a TConsultaPro:

//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 DFM:

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 abaixo, que é 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;
	//métodos de IInterface
	function _AddRef: Integer; stdcall;
	function _Release: Integer; stdcall;
  end;
  //Um tipo de referência de classe, para podermos encontrar e instânciar 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 instânciar
  //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 mecher em nada ou quase nada na form, não podendo mecher 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 mecher nela.
  //Até mesmo mantivemos a regra de negócio no evento do edit,
  //para demosntrar 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 é a unit que tem a nossa classe factory e é onde ela é registrada 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 delphi posteriormente, em uma unit que
  //não a conhece, sem esta unit 2 estar declarada no uses.
  RegisterClass(TFConsultaProFactory);

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

end.

Repare que no exemplo que fizemos registramos uma classe que possui um método para instanciar a 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 uma form feita por outra pessoa que você não pode mecher nem na unit. E num contexto que não era orientado a objeto, mas está em migração. Nada impede de fazer com que a própria form implemente a interface IFrmConsultaPro, o método ConsultaPro e que a própria form seja registrada com registerClass. Mas o release deveria ser automatico, ou deveria-se implementar os métodos _AddRef e _Release.

Usando essas técnicas com criatividade você pode criar um super 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 necessarias 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 queira ficar na memória.

No arquivo para download: Desktop\Estudo_MemoryLeaks_Interfaces, há 4 pastas - exemplos:

MemoryLeak_Interfaces é o código do primeiro exemplo acima, que mostra como implementar _AddRef, _Release e fazer autodestroy e refcount nas Classes TInterfacedPersistent e TComponent.

MemoryLeak_Agregates_UsoCorreto: ilustra a maneira correta de se usar agregates para não gerar memory leak.

MemoryLeak_Interface_RegisterClass mostra o exemplo acima e como transformar aos poucos um sistema legado em sistema orientado a objetos.

MemoryLeak_Interface_RegisterClass Extra é um exemplo extra onde a classe registrada é a propria Form.

Link para o arquivo com os exemplos, no meu skyDrive (use o 7zip para descompactar)

http://cid-a3e4fd1c20f4d546.skydrive.live....sInterfaces.zip

Entrar

Arquivado

[Resolvido] Memory Leaks, Interfaces, Agregates e RegisterClass

Recommended Posts

vitor^_^ 0

Compartilhar este post

Link para o post

Compartilhar em outros sites

PHP+Codeigniter - Dúvida referente a PDV

PHP+Codeigniter - Dúvida em Relação a Teclas

Conexão mysql com outro domínio

Este projeto é apoiado pelas empresas

Fóruns

Tempo Real

Informação importante