Mega Code Archive
Implementing the Singleton pattern in delphi
<![CDATA[
Title: Implementing the Singleton pattern in delphi
Question: The Singleton pattern is one of the most usefull patterns. We all use it, with out our knowladge. Class are an example, TApplication is another.
Here i try to explain what a singleton is, and to bring a usefull example of singleton implementation.
Answer:
Abstruct:
The singleton design pattern defines a variation to the normal Object - Class relation. The variation is that the class creates only one object for all the application, and returns that one object any time someone requests an object of that class.
Note that TComponent cannot be singleton, as TComponent object lifetime is handled by a owner, and a TComponent can have only one owner. Two owners cannot share the same object, so TComponent cannot be Singleton.
Implementing singleton:
There are two ways to implement singleton objects:
1. Add a class function GetInstance, that returns the singleton instance.
This method has the problem of allowing users to create new object using
the Create function.
2. Change the Create function to return the singleton instance.
I have taken the second way. Why? Any function in delphi must have a return type, and this return type for a base singleton class can only be TSingelton. This will force users to typecast the result of the GetInstance function to the tree type of the singleton.
MySingleton := (TMySingleton.GetInstance) as TMySingleton;
However, a constructor allways returns the class beeing constructed. This removes the need to typecast.
MySingleton := TMySingleton.create;
You can also add a new constructor to the TSingleton class called GetInstance, then you will get the following result.
MySingleton := TMySingleton.GetInstance;
So I selected to change the behaviour of the constructors of the TSingleton class. I want the constructor to return a single instance of the object, allways.
In order to make an object singleton, one need to override some functions
of the TObject class:
class Function NewInstance: TObject;
This function allocates memory for a new object. It is called each time a client calls any constructor. This function should allocate memory only the first time an object is created, and return this memory at each following call.
Procedure FreeInstance;
This function free's the memory allocated for the object. It is called
each time a destructor is called.
Normaly a singleton object is destroyed in the Finalization of the unit, so
override this function and leave it empty.
Example:
The example is a two classes I use in some applications, and it includes two classes:
TSingleton - a class that implements the singleton pattern making any decendant classes singletons.
TInterfacedSingleton - The same as TSingleton, only implementing the IUnknown interface (Objects of this class are freed at the Finalization or later if there is another reference to them). This singleton class was usefull at one time, and I thought that it is a nice idea.
How to use the two following classes - Derive a new class from one. If you need any initialization done for you're singleton class, override the Init function. If you need any finalization, override the BeforeDestroy function. To get an instance of the singleton, simply write TMySingletonClass.Create;
Notes:
1. The singelton idea does not require to inherit from one TSingleton base class. The code is just one example, and the implementation is not the pattern. The pattern is the idea itself.
2. The following example is not thread safe. In order to create a thread safe version, you need to make the following functions thread safe:
* TSingleton.NewInstance
* TInterfacedSingleton.NewInstance
* ClearSingletons
The code:
unit uSingleton;
interface
Uses
SysUtils;
Type
TSingleton = class(TObject)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Procedure BeforeDestroy; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
End;
TInterfacedSingleton = class(TInterfacedObject, IUnknown)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
Function _AddRef: Integer; stdcall;
Function _Release: Integer; stdcall;
End;
implementation
Var
SingletonHash: TStringList;
// In my original code I use a true Hash Table, but as delphi does not provide
// one built it, I replaced it here with a TStringList. It should be easy
// to replace with a true hash table if you have one.
{ General}
Procedure ClearSingletons;
Var
I: Integer;
Begin
// call BeforeDestroy for all singleton objects.
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects[I] Is TSingleton then
Begin
TSingleton(SingletonHash.Objects[I]).BeforeDestroy;
End
End;
// free all singleton and InterfacedSingleton objects.
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects[I] Is TSingleton then
Begin
TSingleton(SingletonHash.Objects[I]).Dispose;
End
Else
TInterfacedSingleton(SingletonHash.Objects[I])._Release;
End;
End;
{ TSingleton }
Procedure TSingleton.BeforeDestroy;
Begin
End;
Procedure TSingleton.Dispose;
Begin
Inherited FreeInstance;
End;
Procedure TSingleton.FreeInstance;
Begin
//
End;
Procedure TSingleton.Init;
Begin
End;
class function TSingleton.NewInstance: TObject;
Var
Singleton: TSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TSingleton;
End;
{ TInterfacedSingleton }
procedure TInterfacedSingleton.Dispose;
Begin
Inherited FreeInstance;
End;
procedure TInterfacedSingleton.FreeInstance;
Begin
//
End;
procedure TInterfacedSingleton.Init;
Begin
End;
class function TInterfacedSingleton.NewInstance: TObject;
Var
Singleton: TInterfacedSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TInterfacedSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Singleton._AddRef;
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TInterfacedSingleton;
End;
function TInterfacedSingleton._AddRef: Integer;
Begin
Result := Inherited _AddRef;
End;
function TInterfacedSingleton._Release: Integer;
Begin
Result := Inherited _Release;
End;
Initialization
SingletonHash := Nil;
Finalization
If SingletonHash Nil then
ClearSingletons;
SingletonHash.Free;
End.
]]>