Você já se perguntou como suprimir o método Create para que não seja utilizado? Tentar "esconder" o constructor colocando-o como private não irá funcionar por um motivo simples: ao utilizar o create será visível e perfeitamente "invocável" o create da classe base, que não conterá as informações necessárias para criar realmente o objeto e poderá causar access violations.
O que fazer então?
Na verdade o constructor create nada mais é do que uma espécie de class method (método de classe) especial que serve como alias para o NewInstance. O Create atua como um factory method nativo e bem simples, sendo o NewInstance que efetivamente aloca memória e constroi o objeto.
Então uma maneira muito elegante de se criar um singleton é, em vez de disparar um exception caso o método create seja executado mais de uma vez, sobrecarregar os métodos NewInstance e FreeInstance para impedir que de fato o objeto seja criado duas vezes, ou destruido antes do tempo. Esses métodos são os responsáveis por criar ou destruir um objeto "de verdade" na memoria. Eles que fazem a alocação e desalocação de memoria.
São métodos virtuais. Então sobrecarregando-os e fazendo com que retornem sempre a mesma instancia não importa quantas vezes se execute o create podemos fazer um singleton que trabalha com mais liberdade.
Aqui você vê um tópico interessante sobre o assunto
unit uSingleton;
interface
uses Dialogs, Classes;
type
TMySingleton = class(TObject)
private
FHello: TstringList;
FDateTime: string;
protected
//se executar isso o objeto pode ser destruido
class procedure PrepararParaLiberar; virtual;
//para criar ou destruir os componentes do objeto
procedure InicializarObjeto; virtual;
procedure FinalizarObjeto; virtual;
public
procedure SetHello(vHello: string);
procedure SayHello; virtual;
constructor Create;
//esses caras misticos abaixo que realmente criam, alocam memoria, destroem e desalocam memoria por tráz dos constructor e destructor que conhecemos
class function NewInstance: TObject; override;
procedure FreeInstance; override;
destructor Destroy; override;
class function InstanciaPadrao: TMySingleton; virtual;
end;
implementation
uses SysUtils;
var
_MySingletonInstance: TObject = nil;
_PreparadoParaLiberar: Boolean = False;
{ TMySingleton }
procedure TMySingleton.SayHello;
begin
//um metodo bobo pra testar
ShowMessage('Classe: ' + Self.ClassName + #13#10 +
'Mensagem: ' + FHello.Text + #13#10 +
'Data: ' + FDateTime + #13#10 +
'Instância: ' + inttostr(integer(self)));
end;
procedure TMySingleton.SetHello(vHello: string);
begin
//um outro metodo bobo pra setar a mensagem
FHello.Text := vHello;
end;
constructor TMySingleton.Create;
begin
//antes de tudo, antes mesmo do inherited, newinstance já é chamado por padrão
inherited; //faz o que for preciso de seu ancestral, eu tenho certeza aqui que o NewInstance está sendo executado
InicializarObjeto; //inicializo o que precisa
end;
destructor TMySingleton.Destroy;
begin
FinalizarObjeto; //destruo as partes ou objetos criados pela minha classe, como stringlists
inherited; //a destruição normal do objeto, depois disso freeinstance é chamado normalmente
end;
class function TMySingleton.InstanciaPadrao: TMySingleton;
begin
//isso é apenas um atalho em uma class function
if _MySingletonInstance = nil then
_MySingletonInstance := TMySingleton.Create;
Result := _MySingletonInstance as TMySingleton;
end;
procedure TMySingleton.FreeInstance;
begin
//no destructor não vai acontecer nada se _PreparadoParaLiberar for false, e eu não preciso disparar uma excessão
// agora se _PreparadoParaLiberar for true
//eu faço o que um FreeInstance sempre deveria fazer, uso o inherited,
if _PreparadoParaLiberar then
begin
inherited;
//bloqueio a liberação novamente
_PreparadoParaLiberar := False;
//atribuo nil
_MySingletonInstance := nil;
end;
//agora se precisar pode criar de novo
end;
class function TMySingleton.NewInstance: TObject;
begin
if (_MySingletonInstance = nil) then
begin
//_MySingletonInstance := inherited NewInstance as TMySingleton;
//_MySingletonInstance.FDateTime := FormatDateTime('yyyy-mm-dd hh:nn:ss', now);
_MySingletonInstance := inherited NewInstance;
(_MySingletonInstance as TMySingleton).FDateTime := FormatDateTime('yyyy-mm-dd hh:nn:ss', now);
end;
Result := _MySingletonInstance;
end;
class procedure TMySingleton.PrepararParaLiberar;
begin
//esse método só faz isso
_PreparadoParaLiberar := True;
end;
procedure TMySingleton.FinalizarObjeto;
begin
//aqui você poe somente as coisas que devem acontecer da destruição verdadeira do objeto
if _PreparadoParaLiberar then
begin
FHello.Free;
end;
end;
procedure TMySingleton.InicializarObjeto;
begin
//aqui você poe tudo o que precisa que aconteça depois do create
//lembrando que se o NewInstance já retornar o objeto criado, então
//Self.FHello vai ser o Fhello dessa instancia, e vai ser <> de nil
if (FHello = nil) then
begin
FHello := TStringList.Create;
end;
end;
initialization
//inicializo minhas variáveis publicas, porque vou mecher nelas posteriormente
_MySingletonInstance := nil;
_PreparadoParaLiberar := False;
finalization
if (_MySingletonInstance <> nil) then
try
TMySingleton.PrepararParaLiberar;
_MySingletonInstance.Free;
except
//tratamento de exceção, se precisar
end;
end.
Creio que o código esteja bem comentado, mas explicando: temos aqui as procedures virtuais InicializarObjeto e FinalizarObjeto e temos a class procedure PrepararParaLiberar. InicializarObjeto simplesmente cria os outros objetos dos quais o singleton é dependente/composto e armazena esta instância no campo/atributo apropriado. Por exemplo nosso singleton faz uso de uma TStringList, então é nesta procedure, InicializarObjeto, que ele será criado. Analogamente ele será destruido em FinalizarObjeto. O trecho de código abaixo garante que a TStringList FHello será criada apenas quando não existir e será destruída apenas quando o singleton não for mais necessário, evitando-se memory leaks.
procedure TMySingleton.FinalizarObjeto;
begin
//aqui você poe somente as coisas que devem acontecer da destruição verdadeira do objeto
if _PreparadoParaLiberar then
begin
FHello.Free;
end;
end;
procedure TMySingleton.InicializarObjeto;
begin
//aqui você poe tudo o que precisa que aconteça depois do create
//lembrando que se o NewInstance já retornar o objeto criado, então
//Self.FHello vai ser o Fhello dessa instancia, e vai ser <> de nil
if (FHello = nil) then
begin
FHello := TStringList.Create;
end;
end;
O fato de ambas serem virtuais e protected é muito importante para evitar que sejam invocadas pelo "client" do singleton e mesmo assim permitir que sejam sobrecarregadas no descendente com a diretiva "override"
A class procedure PrepararParaLiberar apenas ativa uma flag booleana que permite que o singleton seja destruído de verdade.
As procedures SayHello e SetHello apenas mostram ou definem o valor da propriedade Text de FHello que é a mensagem a ser exibida. Considere-os como as operações/serviços principais do seu singleton, como fábricas de componentes de acesso a bancos de dados, por exemplo.
procedure TMySingleton.SayHello;
begin
//um metodo bobo pra testar
ShowMessage('Classe: ' + Self.ClassName + #13#10 +
'Mensagem: ' + FHello.Text + #13#10 +
'Data: ' + FDateTime + #13#10 +
'Instância: ' + inttostr(integer(self)));
end;
procedure TMySingleton.SetHello(vHello: string);
begin
//um outro metodo bobo pra setar a mensagem
FHello.Text := vHello;
end;
Além de mostrar o nome da classe e a mensagem também mostramos a data e o endereço de memória do objeto. Não confunda com @self, pois @self dará o endereço da variável self de cada instancia, podendo ser diferente para duas variaveis mesmo que apontem para a mesma instancia. Self é o endereço do objeto e de qualquer variável que aponte para ele.
Manter os métodos "Inicializa" e "Finaliza" ajudará a mechar o menos possível no Create e no Destroy, pois as configurações de inicialização ou a limpeza de objetos antes da destruição não ficam no corpo dos métodos create e destroy mas sim no corpo dos métodos Inicializa e Finaliza, que são invocados por Create e Destroy respectivamente.
constructor TMySingleton.Create;
begin
//antes de tudo, antes mesmo do inherited, newinstance já é chamado por padrão
inherited; //faz o que for preciso de seu ancestral, eu tenho certeza aqui que o NewInstance está sendo executado
InicializarObjeto; //inicializo o que precisa
end;
destructor TMySingleton.Destroy;
begin
FinalizarObjeto; //destruo as partes ou objetos criados pela minha classe, como stringlists
inherited; //a destruição normal do objeto, depois disso freeinstance é chamado normalmente
end;
A mágica de verdade acontece nos métodos NewInstance e FreeInstance. O método NewInstance sempre é uma function que retorna uma instância do objeto recém criado; Objeto este do tipo da classe em questão. Create chama NewInstance e isso pode ser observado com o Debug, da mesma forma que Destroy chama FreeInstance.
O que é feito nesse singleton é manter uma variável do tipo _MySingletonInstance: TMySingleton estática, na seção implementation (global, mas visível apenas nesta unit);
procedure TMySingleton.FreeInstance;
begin
//no destructor não vai acontecer nada se _PreparadoParaLiberar for false, e eu não preciso disparar uma excessão
// agora se _PreparadoParaLiberar for true
//eu faço o que um FreeInstance sempre deveria fazer, uso o inherited,
if _PreparadoParaLiberar then
begin
inherited;
//bloqueio a liberação novamente
_PreparadoParaLiberar := False;
//atribuo nil
_MySingletonInstance := nil;
end;
//agora se precisar pode criar de novo
end;
class function TMySingleton.NewInstance: TObject;
begin
if (_MySingletonInstance = nil) then
begin
//_MySingletonInstance := inherited NewInstance as TMySingleton;
//_MySingletonInstance.FDateTime := FormatDateTime('yyyy-mm-dd hh:nn:ss', now);
_MySingletonInstance := inherited NewInstance;
(_MySingletonInstance as TMySingleton).FDateTime := FormatDateTime('yyyy-mm-dd hh:nn:ss', now);
end;
Result := _MySingletonInstance;
end;
Porque _MySingletonInstance é do tipo TObject e não do tipo TMySingleton? Simples: porque assim não precisa fazer a conversão de tipo na hora de atribuir a NewInstance, apenas na hora de setar o datetime ou na execução do método InstanciaPadrao ( Result := _MySingletonInstance as TMySingleton;)
Essa mudança permite que um singleton base e um derivado sejam criados em seguida sem dar invalid typecast na hora de chamar NewInstance, pois NewInstance grava
As seções initialization e finalization garantem que o singleton seja armazenado em uma variável limpa e seja destruído no final da aplicação.
initialization
//inicializo minhas variáveis publicas, porque vou mecher nelas posteriormente
_MySingletonInstance := nil;
_PreparadoParaLiberar := False;
finalization
if (_MySingletonInstance <> nil) then
try
TMySingleton.PrepararParaLiberar;
_MySingletonInstance.Free;
except
//tratamento de exceção, se precisar
end;
Há um post sobre um singleton no fórum DevMedia que pode ser herdado, contanto que alguns métodos sejam obrigatoriamente usados. O problema é que não se pode usar um singleton da classe base e outro da classe derivada ao mesmo tempo. Eles compartilham dados em comum, já que o singleton da classe derivada é o mesmo que a classe base com algo a mais.
O tópico foi evoluindo até chegar ao que foi visto nesta minha série de artigos. Os primeiros singletons do tópico pareciam com o singleton deste primeiro artigo. O último já estava mais parecido com este.
Mesmo esta versão mais nova, com todos os cuidados tomados, ainda não pode ser usada juntamente com sua herdeira.
Veja bem, ela pode ser Herdada, mas ou usa-se a classe base ou usa-se a classe filha separadamente. Caso use as duas o que acontecerá? Se você instanciar primeiro a classe base e depois a derivada, ambos os singletons serão da classe base, e se você instanciar a classe derivada primeiro, amboes serão da classe derivada. Isso porque o result de inherited NewInstance é armazenado na variável _MySingletonInstance, ou na _MySingletonDerivadoInstance para classe derivada. Essa variável que contém as instâncias não conseguem diferenciar qual classe está chamando NewInstance e a instância em si é gravada nas duas variáveis.
if (_MySingletonDerivadoInstance = nil) then
begin
//_MySingletonDerivadoInstance := inherited NewInstance as TMySingletonDerivado;
_MySingletonDerivadoInstance := inherited NewInstance;
end;
Result := _MySingletonDerivadoInstance;
Eu ainda não consegui resolver esse problema de utilizar as duas classes. Ele não pode ser resolvido simplesmente omitindo-se ou suprimindo o inherited ou reescrevendo todos os métodos e substituindo todas as variáveis
como no exemplo anterior. Na verdade ter que reimplementar todos os métodos não é uma herança inteligente, é uma herança burra, um despropósito: pra que herdar se eu tenho que fazer tudo de novo do zero e não aproveito o polimorfismo?
A classe filha, o singleton derivado, foi criado assim:
unit uSingletonDerivado;
interface
uses uSingleton, Dialogs, Classes;
type
TMySingletonDerivado = class(TMySingleton)
protected
class procedure PrepararParaLiberar; override;
procedure InicializarObjeto; override;
procedure FinalizarObjeto; override;
public
//constructor Create;
class function NewInstance: TObject; override;
procedure FreeInstance; override;
//destructor Destroy; override;
class function InstanciaPadrao: TMySingletonDerivado; reintroduce;
end;
implementation
var
_MySingletonDerivadoInstance: TObject = nil;
_PreparadoParaLiberarDerivado: Boolean = False;
{ TMySingletonDerivado }
//*******************************************************************
//* Repare que não foi necessário sobrescrever o Create e o Destroy *
//*******************************************************************
//constructor TMySingletonDerivado.Create;
//begin
// inherited;
// InicializarObjeto;
//end;
//destructor TMySingletonDerivado.Destroy;
//begin
// FinalizarObjeto;
// inherited;
//end;
procedure TMySingletonDerivado.FinalizarObjeto;
begin
inherited;
end;
procedure TMySingletonDerivado.InicializarObjeto;
begin
inherited;
end;
class function TMySingletonDerivado.InstanciaPadrao: TMySingletonDerivado;
begin
if _MySingletonDerivadoInstance = nil then
_MySingletonDerivadoInstance := TMySingletonDerivado.Create;
Result := _MySingletonDerivadoInstance as TMySingletonDerivado;
end;
procedure TMySingletonDerivado.FreeInstance;
begin
if _PreparadoParaLiberarDerivado then
begin
_PreparadoParaLiberarDerivado := False;
_MySingletonDerivadoInstance := nil;
inherited;
end;
end;
class function TMySingletonDerivado.NewInstance: TObject;
begin
if (_MySingletonDerivadoInstance = nil) then
begin
//_MySingletonDerivadoInstance := inherited NewInstance as TMySingletonDerivado;
_MySingletonDerivadoInstance := inherited NewInstance;
end;
Result := _MySingletonDerivadoInstance;
end;
class procedure TMySingletonDerivado.PrepararParaLiberar;
begin
_PreparadoParaLiberarDerivado := True;
inherited;
end;
initialization
_MySingletonDerivadoInstance := nil;
_PreparadoParaLiberarDerivado := False;
finalization
if (_MySingletonDerivadoInstance <> nil) then
try
TMySingletonDerivado.PrepararParaLiberar;
_MySingletonDerivadoInstance.Free;
except
//tratamento de exceção, se precisar
end;
end.
Para testar vários quesitos devem ser testados: primeiro de tudo se não estão se criando várias instâncias, depois se a criação e destruição fluem normalmente, se a destruição só é possível quando autorizado/preparado e se instâncias de classes diferentes não se atrapalham mutuamente (este teste não está passando).
Para o teste construa um formulário como este:
E este código:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, uSingleton, uSingletonDerivado;
type
TfrmSingleton = class(TForm)
btTeste1: TButton;
btTeste2: TButton;
btTEste3: TButton;
btTeste4: TButton;
btTeste6: TButton;
Label1: TLabel;
Label2: TLabel;
btTeste5: TButton;
Label3: TLabel;
btTesteDerivado1: TButton;
btTesteDerivado2: TButton;
btTesteDerivado3: TButton;
btTesteDerivado4: TButton;
btTesteDerivado5: TButton;
btTesteDerivado6: TButton;
btTesteDerradeiro: TButton;
Label4: TLabel;
btCria1: TButton;
btCria2: TButton;
btTesta1: TButton;
btTesta2: TButton;
btDestroi1: TButton;
btDestroi2: TButton;
procedure btTeste1Click(Sender: TObject);
procedure btTeste2Click(Sender: TObject);
procedure btTEste3Click(Sender: TObject);
procedure btTeste4Click(Sender: TObject);
procedure btTeste6Click(Sender: TObject);
procedure btTeste5Click(Sender: TObject);
procedure btTesteDerivado3Click(Sender: TObject);
procedure btTesteDerivado4Click(Sender: TObject);
procedure btTesteDerivado1Click(Sender: TObject);
procedure btTesteDerivado2Click(Sender: TObject);
procedure btTesteDerivado5Click(Sender: TObject);
procedure btTesteDerivado6Click(Sender: TObject);
procedure btCria1Click(Sender: TObject);
procedure btCria2Click(Sender: TObject);
procedure btTesta1Click(Sender: TObject);
procedure btTesta2Click(Sender: TObject);
procedure btDestroi1Click(Sender: TObject);
procedure btDestroi2Click(Sender: TObject);
private
{ Private declarations }
public
FMySingleton: TMySingleton;
FMySingleton1: TMySingleton;
FMySingleton2: TMySingleton;
FMySingletonDer1: TMySingletonDerivado;
FMySingletonDer2: TMySingletonDerivado;
teste1: TMySingleton;
teste2: TMySingletonDerivado;
end;
var
frmSingleton: TfrmSingleton;
implementation
{$R *.dfm}
procedure TfrmSingleton.btTeste1Click(Sender: TObject);
begin
FMySingleton1 := TMySingleton.Create;
with FMySingleton1 do
begin
SetHello('teste1');
SayHello;
end;
FMySingleton1.SayHello;
FMySingleton1.Free;
end;
procedure TfrmSingleton.btTeste2Click(Sender: TObject);
begin
FMySingleton2 := TMySingleton.Create;
with FMySingleton2 do
begin
//não vamos mudar a mensagem, veremos que é a mesma do teste anterior
//SetHello('teste2');
SayHello;
end;
FMySingleton2.SayHello;
end;
procedure TfrmSingleton.btTEste3Click(Sender: TObject);
begin
FMySingleton1 := TMySingleton.InstanciaPadrao;
FMySingleton1.SayHello;
end;
procedure TfrmSingleton.btTeste4Click(Sender: TObject);
begin
FMySingleton2 := TMySingleton.InstanciaPadrao;
FMySingleton2.SayHello;
end;
procedure TfrmSingleton.btTesteDerivado6Click(Sender: TObject);
var fmst: TMySingletonDerivado;
begin
fmst := TMySingletonDerivado.Create;
fmst.SetHello('testeA');
fmst.SayHello;
//mesmo com várias tentativas de criação e destruição a instância se mantem a mesma
fmst := TMySingletonDerivado.Create;
fmst := TMySingletonDerivado.Create;
fmst := TMySingletonDerivado.Create;
fmst.SetHello('testeB');
fmst.SayHello;
fmst.Free;
fmst.Free;
fmst.Free;
fmst.Destroy;
fmst.Destroy;
fmst.Destroy;
fmst.SetHello('testeC');
fmst.SayHello;
end;
procedure TfrmSingleton.btCria1Click(Sender: TObject);
begin
teste1 := TMySingleton.Create;
teste1.SetHello('hello 1');
end;
procedure TfrmSingleton.btCria2Click(Sender: TObject);
begin
teste2 := TMySingletonDerivado.Create;
teste2.SetHello('hello 2');
end;
procedure TfrmSingleton.btTesta1Click(Sender: TObject);
begin
teste1.SayHello;
end;
procedure TfrmSingleton.btTesta2Click(Sender: TObject);
begin
teste2.SayHello;
end;
procedure TfrmSingleton.btDestroi1Click(Sender: TObject);
begin
teste1.Free;
end;
procedure TfrmSingleton.btDestroi2Click(Sender: TObject);
begin
teste2.Free;
end;
procedure TfrmSingleton.btTesteDerivado1Click(Sender: TObject);
begin
FMySingletonDer1 := TMySingletonDerivado.Create;
with FMySingletonDer1 do
begin
SetHello('teste4');
SayHello;
end;
FMySingletonDer1.SayHello;
FMySingletonDer1.Free;
end;
procedure TfrmSingleton.btTesteDerivado2Click(Sender: TObject);
begin
FMySingletonDer2 := TMySingletonDerivado.Create;
with FMySingletonDer2 do
begin
//SetHello('teste5');
SayHello;
end;
FMySingletonDer2.SayHello;
end;
procedure TfrmSingleton.btTesteDerivado3Click(Sender: TObject);
begin
//FMySingletonDer1 := TMySingletonDerivado.InstanciaPadrao;
FMySingletonDer1.SayHello;
end;
procedure TfrmSingleton.btTesteDerivado4Click(Sender: TObject);
begin
//FMySingletonDer2 := TMySingletonDerivado.InstanciaPadrao;
FMySingletonDer2.SayHello;
end;
procedure TfrmSingleton.btTesteDerivado5Click(Sender: TObject);
begin
TMySingletonDerivado.InstanciaPadrao.SetHello('teste6');
TMySingletonDerivado.Create.SayHello;
TMySingletonDerivado.InstanciaPadrao.SayHello;
end;
procedure TfrmSingleton.btTeste6Click(Sender: TObject);
var fmst: TMySingleton;
begin
fmst := TMySingleton.Create;
fmst.SetHello('testeA');
fmst.SayHello;
//mesmo com várias tentativas de criação e destruição a instância se mantem a mesma
fmst := TMySingleton.Create;
fmst := TMySingleton.Create;
fmst := TMySingleton.Create;
fmst.SetHello('testeB');
fmst.SayHello;
fmst.Free;
fmst.Free;
fmst.Free;
fmst.Destroy;
fmst.Destroy;
fmst.Destroy;
fmst.SetHello('testeC');
fmst.SayHello;
end;
procedure TfrmSingleton.btTeste5Click(Sender: TObject);
begin
TMySingleton.InstanciaPadrao.SetHello('teste3');
TMySingleton.Create.SayHello;
TMySingleton.InstanciaPadrao.SayHello;
end;
end.
Ainda existe um erro ao se executar os testes 1 do singleton base e logo depois o 5 do singleton derivado. Isso porque a instância será um TMySingleton, e seria inválido fazer o typecast para TMySingletonDerivado.
Isso pode ser contornado fazendo com que InstnciaPadrao retorne TMySingleton, assim:
class function TMySingletonDerivado.InstanciaPadrao: TMySingleton;
begin
if _MySingletonDerivadoInstance = nil then
_MySingletonDerivadoInstance := TMySingletonDerivado.Create;
Result := _MySingletonDerivadoInstance as TMySingleton;
end;
Ou então suprimindo-se completamente este método.
O código atualizado tanto para Delphi como para lazarus pode ser baixado aqui:
http://www.vitorrubio.com.br/downloads/Exemplo_Singleton_3.zip
Nos próximos dois artigos faremos mudanças que funcionarão apenas no Delphi 2009 em diante, e o lazarus ficará de fora. No exemplo 4 transformaremos as variáveis estáticas globais da unit em variaveis/propriedades de classe e no exemplo 5 criaremos um singleton com generics. Até lá!
PS.: Eu tenho o péssimo hábito de escrever exceção errado, com dois "S" e só percebo depois, por isso onde estiver excessão leia-se exceção.
Comentários
Postar um comentário