Articles

Creating a subclassable singleton class in Delphi

After searching for techniques to create singleton classes in Delphi, I found none that could be subclassed. See for example Creating a real singleton class in Delphi. I therefore decided to create such a class myself, roughly based on the example in that link.

The Singleton class' unit

Usage:

unit ssSingleton;

interface

uses SysUtils;

type
  EssSingletonException = class(Exception);

  TssSingleton = class(TObject)
  private
    class function RefCount: Cardinal;
  public
    constructor Create;
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
    procedure CreateSingleton; virtual; abstract;
  end;

implementation

uses Classes;

type
  // Define structure that contains the reference count and object pointer.
  PssSingletonInstance = ^TssSingletonInstance;
  TssSingletonInstance = record
    refcount: Cardinal;
    instance: TObject;
  end;

// The instances: classname => TssSingletonInstance pairs
var
  instances: TStrings;


procedure CleanupInstances;
var
  i: integer;
begin
  for i := instances.Count-1 downto 0 do begin
    if PssSingletonInstance(instances.Objects[i])^.refcount > 1 then begin
      PssSingletonInstance(instances.Objects[i]).instance.Free;
      if (i <= instances.Count) then begin
        Dispose(PssSingletonInstance(instances.Objects[i]));
        instances.Delete(i);
      end;
    end
    else
      PssSingletonInstance(instances.Objects[i]).instance.Free;
  end;
  instances.Free; // Added 2006-12-11, thanks to Graeme Geldenhuys.
end;


constructor TssSingleton.Create;
begin
  inherited;
  if (RefCount <= 1) then
    CreateSingleton;
end;


procedure TssSingleton.FreeInstance;
var
  i: integer;
  instance: PssSingletonInstance;
begin
  i := instances.IndexOf(ClassName);
  if i < 0 then begin // no instance found!
    inherited;
    Exit;
  end;
  instance := PssSingletonInstance(instances.Objects[i]);
  if (instance^.refcount > 1) then
    Dec(instance^.refcount)
  else begin
    inherited FreeInstance; // free instance here
    // free and remove the PssSingletonInstance from the list.
    Dispose(PssSingletonInstance(instances.Objects[i]));
    instances.Delete(i);
  end;
end;


class function TssSingleton.NewInstance: TObject;
var
  i: integer;
  instance: PssSingletonInstance;
begin
  i := instances.IndexOf(ClassName);
  if i >= 0 then begin // instance found
    instance := PssSingletonInstance(instances.Objects[i]);
  end
  else begin
    new(instance);
    instance^.instance := inherited NewInstance;
    instance^.refcount := 0;
    instances.AddObject(ClassName,TObject(instance));
  end;
  Inc(instance^.refcount);
  Result := instance^.instance;
end;


class function TssSingleton.RefCount: Cardinal;
var
  i: integer;
  instance: PssSingletonInstance;
begin
  i := instances.IndexOf(ClassName);
  if i >= 0 then begin // instance found
    instance := PssSingletonInstance(instances.Objects[i]);
    Result := instance^.refcount;
  end
  else
    raise EssSingletonException.Create('Class "' + ClassName +
                                       '" not found in instances list!');
end;


initialization
  instances := TStringList.Create;


finalization
  CleanupInstances;

end.

This is how it works:

About threads:

Two simple examples of subclasses of the Singleton class

Below are 2 listings. They are both singleton classes meant for storing and retrieving the name of a fruit or vegetable. These are of course not very useful classes but are only meant for demonstration anyway. Both classes descend from TSingleton and add a private field FData with and accessor property Data. I named these classes SingletonFruit and SingletonVeg respectively. All descendents of TSingleton must override the CreateSingleton() method. This method is called automatically from the constructor when the constructor is called for the first time.

unit SingletonFruit;

interface

uses ssSingleton;

type
  TSingletonFruit = class(TssSingleton)
  private
    FData: string;
  public
    procedure CreateSingleton; override;
    property Data: string read FData write FData;
  end;

implementation

procedure TSingletonFruit.CreateSingleton;
begin
  FData := 'Banana'; // the default fruit name
end;

end.

unit SingletonVeg;

interface

uses ssSingleton;

type
  TSingletonVeg = class(TssSingleton)
  private
    FData: string;
  public
    procedure CreateSingleton; override;
    property Data: string read FData write FData;
  end;

implementation

procedure TSingletonVeg.CreateSingleton;
begin
  FData := 'Sprouts'; // the default vegetable name
end;

end.

A simple usage example

Below is the listing of a test program to check if this concept really works.

program Project1;
{$APPTYPE CONSOLE}
uses
  SysUtils,
  SingletonFruit in 'SingletonFruit.pas',
  SingletonVeg in 'SingletonVeg.pas';

var
  fruit1, fruit2: TSingletonFruit;
  veg1, veg2: TSingletonVeg;

begin
  fruit1 :=  TSingletonFruit.Create;
  fruit2 :=  TSingletonFruit.Create;
  veg1 := TSingletonVeg.Create;
  veg2 := TSingletonVeg.Create;

  fruit1.Data := 'Apple';
  fruit2.Data := 'Lemon';
  veg1.Data := 'Tomato';
  veg2.Data := 'Potato';

  writeln('Fruit 1 contains: ' + fruit1.Data);
  writeln('Fruit 2 contains: ' + fruit2.Data);
  writeln('Vegetable 1 contains: ' + veg1.Data);
  writeln('Vegetable 2 contains: ' + veg2.Data);
end.

Executing the program above results in this output as expected:

Fruit 1 contains: Lemon
Fruit 2 contains: Lemon
Vegetable 1 contains: Potato
Vegetable 2 contains: Potato

Some singleton ideas

The singleton class above is a module wide singleton. If your application consists of an EXE and a DLL, each with the same singleton class, then you'll end up with 2 singleton instances instead of 1 as you might expect.
To solve this problem, you can create a process wide singleton class by not storing all instances in a global variable such as "instances: TStrings;" as in my example, but in a memory mapped file (shared memory). You can also use this technique to create a system wide singleton class which can be shared amongst seperate processes on the same system.