Author: Yoav Abrahami
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:
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.
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
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.
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
Code
1 unit uSingleton;
2
3 interface
4
5 uses
6 SysUtils;
7
8 type
9 TSingleton = class(TObject)
10 private
11 procedure Dispose;
12 protected
13 procedure Init; virtual;
14 procedure BeforeDestroy; virtual;
15 public
16 class function NewInstance: TObject; override;
17 procedure FreeInstance; override;
18 end;
19
20 TInterfacedSingleton = class(TInterfacedObject, IUnknown)
21 private
22 procedure Dispose;
23 protected
24 procedure Init; virtual;
25 public
26 class function NewInstance: TObject; override;
27 procedure FreeInstance; override;
28 function _AddRef: Integer; stdcall;
29 function _Release: Integer; stdcall;
30 end;
31
32 implementation
33
34 var
35 SingletonHash: TStringList;
36 // In my original code I use a true Hash Table, but as delphi does not provide
37 // one built it, I replaced it here with a TStringList. It should be easy
38 // to replace with a true hash table if you have one.
39
40 { General}
41
42 procedure ClearSingletons;
43 var
44 I: Integer;
45 begin
46 // call BeforeDestroy for all singleton objects.
47 for I := 0 to SingletonHash.Count - 1 do
48 begin
49 if SingletonHash.Objects[I] is TSingleton then
50 begin
51 TSingleton(SingletonHash.Objects[I]).BeforeDestroy;
52 end
53 end;
54
55 // free all singleton and InterfacedSingleton objects.
56 for I := 0 to SingletonHash.Count - 1 do
57 begin
58 if SingletonHash.Objects[I] is TSingleton then
59 begin
60 TSingleton(SingletonHash.Objects[I]).Dispose;
61 end
62 else
63 TInterfacedSingleton(SingletonHash.Objects[I])._Release;
64 end;
65 end;
66
67 { TSingleton }
68
69 procedure TSingleton.BeforeDestroy;
70 begin
71
72 end;
73
74 procedure TSingleton.Dispose;
75 begin
76 inherited FreeInstance;
77 end;
78
79 procedure TSingleton.FreeInstance;
80 begin
81 //
82 end;
83
84 procedure TSingleton.Init;
85 begin
86
87 end;
88
89 class function TSingleton.NewInstance: TObject;
90 var
91 Singleton: TSingleton;
92 begin
93 if SingletonHash = nil then
94 SingletonHash := TStringList.Create;
95 if SingletonHash.IndexOf(Self.ClassName) = -1 then
96 begin
97 Singleton := TSingleton(inherited NewInstance);
98 try
99 Singleton.Init;
100 SingletonHash.AddObject(Self.ClassName, singleton);
101 except
102 Singleton.Dispose;
103 raise;
104 end;
105 end;
106 Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as
107 TSingleton;
108 end;
109
110 { TInterfacedSingleton }
111
112 procedure TInterfacedSingleton.Dispose;
113 begin
114 inherited FreeInstance;
115 end;
116
117 procedure TInterfacedSingleton.FreeInstance;
118 begin
119 //
120 end;
121
122 procedure TInterfacedSingleton.Init;
123 begin
124
125 end;
126
127 class function TInterfacedSingleton.NewInstance: TObject;
128 var
129 Singleton: TInterfacedSingleton;
130 begin
131 if SingletonHash = nil then
132 SingletonHash := TStringList.Create;
133 if SingletonHash.IndexOf(Self.ClassName) = -1 then
134 begin
135 Singleton := TInterfacedSingleton(inherited NewInstance);
136 try
137 Singleton.Init;
138 SingletonHash.AddObject(Self.ClassName, singleton);
139 Singleton._AddRef;
140 except
141 Singleton.Dispose;
142 raise;
143 end;
144 end;
145 Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as
146 TInterfacedSingleton;
147 end;
148
149 function TInterfacedSingleton._AddRef: Integer;
150 begin
151 Result := inherited _AddRef;
152 end;
153
154 function TInterfacedSingleton._Release: Integer;
155 begin
156 Result := inherited _Release;
157 end;
158
159 initialization
160 SingletonHash := nil;
161
162 finalization
163 if SingletonHash <> nil then
164 ClearSingletons;
165 SingletonHash.Free;
166
167 end.
|
