Implementing the Singleton pattern in delphi

Problem/Question/Abstract:

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

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.