Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
Member Area
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Become a Member
-Why sign up!
-Chat Online!
-Indexes NEW!!
-Build your resume
-Find a job
-Post a job
-Resume Search
-Link to us
Visit Embarcadero
Embarcadero Community
How to Implement the Singleton pattern in delphi Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
Delphi 5.x
User Rating
No Votes
# Votes
DSP, Administrator
Reference URL:
			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.



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. 


The example is a two classes I use in some applications, and it includes two 

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; 


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: 



1   unit uSingleton;
3   interface
5   uses
6     SysUtils;
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;
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;
32  implementation
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.
40    { General}
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;
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;
67  { TSingleton }
69  procedure TSingleton.BeforeDestroy;
70  begin
72  end;
74  procedure TSingleton.Dispose;
75  begin
76    inherited FreeInstance;
77  end;
79  procedure TSingleton.FreeInstance;
80  begin
81    //
82  end;
84  procedure TSingleton.Init;
85  begin
87  end;
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;
110 { TInterfacedSingleton }
112 procedure TInterfacedSingleton.Dispose;
113 begin
114   inherited FreeInstance;
115 end;
117 procedure TInterfacedSingleton.FreeInstance;
118 begin
119   //
120 end;
122 procedure TInterfacedSingleton.Init;
123 begin
125 end;
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;
149 function TInterfacedSingleton._AddRef: Integer;
150 begin
151   Result := inherited _AddRef;
152 end;
154 function TInterfacedSingleton._Release: Integer;
155 begin
156   Result := inherited _Release;
157 end;
159 initialization
160   SingletonHash := nil;
162 finalization
163   if SingletonHash <> nil then
164     ClearSingletons;
165   SingletonHash.Free;
167 end.

Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10


Share this page
Download from Google

Copyright © Mendozi Enterprises LLC