TDM#7: Design Patterns; Singleton

"In their book Design Patterns, Gamma et al (a.k.a. the gang of four) lay the foundation for a new way of approaching software design. [...] In this article we will first look at the language elements that are unique to Object Pascal when compared to C++ and how this makes many of the problems the design patterns try to solve, non-existent, or at least much easier to solve. Then we will look at one example of a very simple design pattern, the Singleton pattern, and how this can best be implemented in Delphi."

H.Vassbotn, The Delphi Magazine, January 1999

This is one of my higher level TDM articles. It revolves around the discussion of the Singleton pattern and implementing it in a reusable fashion in Delphi. Singleton is one of the design patterns with a more dubious value - it is not well suited for multithreaded code and often it preemptively decides that there should only be a single instance of a specific class. Nevertheless, it can have its uses and the article does show some hacks to make the default constructor and destructor unavailable, for instance.

"Even if the goal of designing a Singleton class might seem very simple, there are a number of points we must consider:

· When and by whom should the single instance be created?
· When and by whom should the single instance be destroyed?
· How should external clients get access to the single instance?
· How can we avoid that the value of the instance reference is corrupted?
· How can we avoid illegal creation of additional instances?
· How can we avoid illegal destruction of the single instance?
· How can we keep the design of the Singleton class, but still allow extension by inheritance?"

At the time, class variables were not present in the language, something I bemoan in the article. However, my idea of a useful class variable implementation differs from what we eventually got (and what most sane men would expect ;) ).

"Class fields is such a unusual concepts for most Pascal programmers, so many find it hard to grasp how they should work, if they were part of the language. In OP we do have hard-coded, read only class fields, such as ClassName, InstanceSize, RTTI pointers etc. These are accessed through class functions, but the actual information is stored as part of the extended VMT (virtual method table). This is how class fields should be implemented as well. A class field follows the VMT, so each new derived class has a separate copy of the class field slot."

So I wanted proper per-class (per-VMT) class variables, not the global-variables-in-disguise class vars we have now (each child class shares the class var it inherits with all other classes in the same part of the hierarchy). This has since been discussed in this log here and here.

Another amusing part of the article is my need to uphold the merits of the Delphi Object Pascal Language.

"Object Pascal as a better language

Many people (not to mention the popular computer press) tend to believe that Object Pascal (OP from now on) has only a subset of the language features of C++. While it is true that OP lacks features like multiple inheritance, operator overloading (except for the array subscript operator [..]) and templates, it still has an array of language features not found in C++. Over the years OP has borrowed many features from C++, for good or for worse. I sincerely hope they will not copy all of them – C++ is such a complex language with many pitfalls for both the novice and experienced programmer.

If we look at the language elements unique to OP, we find an amazing array of useful features: units, sets, sub-ranges, native DLL support, class types, class reference variables, virtual class methods, virtual constructors, extensive runtime type-information (RTTI), message methods, dynamic methods, the override keyword, properties, the try..finally clause, initialization and finalization sections, variants, threadvars, native COM support, interfaces, packages, dynamic arrays, interface delegation, automatic reference counting mechanism, and method pointers. I could go on. This is not intended as an exercise in C++ bashing, but rather an attempt to heighten our awareness of the goodies of OP we are enjoying daily."

Well, today we do have proper operator overloading and a template-like facility is (or will become for Win32) available in the form of generics. Still, I do stand by the statement that Object Pascal is a rich, capable and easy-to-use language.

Here is the general, reusable part of the Singleton code:

unit HVSingleton;

interface

uses
  SysUtils;

type
  ESingleton = class(Exception);

  TInvalidateDestroy = class(TObject)
  protected
    class procedure SingletonError;
  public
    destructor Destroy; override;
  end;

  TSingletonOpaqueInfo = record end;
  TSingletonHandle = ^TSingletonOpaqueInfo;
  TSingleton = class;
  TSingletonClass = class of TSingleton;
  TSingleton = class(TInvalidateDestroy)
  private
    class procedure Startup;
    class procedure Shutdown;
  protected
    // Allow descendents register themselves
    class function RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
    // Allow descendents to set a new class for the instance:
    class procedure OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
    // Interface for descendents to get their instance pointer
    class function InstanceOf(Handle: TSingletonHandle): TSingleton;
    // Actual constructor and destructor that will be used:
    constructor SingletonCreate; virtual;
    destructor SingletonDestroy; virtual;
  public
    // Not for use - for obstruction only:
    class procedure Create;
    class procedure Free(Dummy: integer);
{$IFNDEF VER120} {$WARNINGS OFF} {$ENDIF}
    // This generates a warning in D3. D4 has the reintroduce keyword to solve this
    class procedure Destroy(Dummy: integer); {$IFDEF VER120} reintroduce; {$ENDIF}
  end;
{$IFNDEF VER120} {$WARNINGS ON} {$ENDIF}

implementation

uses
  Classes;

{ TInvalidateDestroy }

class procedure TInvalidateDestroy.SingletonError;
// Raise an exception in case of illegal use
begin
  raise ESingleton.CreateFmt('Illegal use of %s singleton instance!', [ClassName]);
end;

destructor TInvalidateDestroy.Destroy;
// Protected against use of default destructor
begin
  SingletonError;
end;

{ TSingleton }

var
  SingletonInstances : TList; { of TSingletons       }
  SingletonClasses   : TList; { of TSingletonClasses }

class procedure TSingleton.Startup;
begin
  SingletonInstances := TList.Create;
  SingletonClasses   := TList.Create;
end;

class procedure TSingleton.Shutdown;
// Time to close down the show
var
  SingletonInstance: TSingleton;
  i : integer;
begin
  // Free any singleton instances
  for i := SingletonInstances.Count-1 downto 0 do
  begin
    SingletonInstance := TSingleton(SingletonInstances.List^[i]);
    if Assigned(SingletonInstance) then
      SingletonInstance.SingletonDestroy;
  end;
  // Free the lists
  SingletonInstances.Free; SingletonInstances := nil;
  SingletonClasses  .Free; SingletonClasses   := nil;
end;

class function TSingleton.RegisterSingletonClass(aSingletonClass: TSingletonClass): TSingletonHandle;
// Register a new Singleton class and allocate space for the instance pointer
var
  Index: integer;
begin
  Assert(Assigned(aSingletonClass));
  Assert(SingletonClasses.IndexOf(Pointer(aSingletonClass)) < 0);
  SingletonClasses.Add(Pointer(aSingletonClass));
  // Return the index +1 of the instace pointer as a handle
  Index := SingletonInstances.Add(nil);
  Result := TSingletonHandle(Index+1);
  Assert(SingletonClasses.Count = SingletonInstances.Count);
end;

class procedure TSingleton.OverrideSingletonClass(BaseSingletonClass, NewSingletonClass: TSingletonClass);
// Allow change of instance class
var
  ThisClass: TSingletonClass;
  i : integer;
begin
  Assert(Assigned(BaseSingletonClass));
  Assert(Assigned(NewSingletonClass));
  Assert(BaseSingletonClass <> TSingleton);
  Assert(NewSingletonClass.InheritsFrom(BaseSingletonClass));
  for i := 0 to SingletonClasses.Count-1 do
  begin
    ThisClass := TSingletonClass(SingletonClasses.List^[i]);
    if ThisClass.InheritsFrom(BaseSingletonClass) and
       (SingletonInstances.List^[i] = nil)        then
    begin
      SingletonClasses.List^[i] := Pointer(NewSingletonClass);
      Exit;
    end;
  end;
  // If we get, here the base class was not found or
  // an instance had already been created
  SingletonError;
end;

class function TSingleton.InstanceOf(Handle: TSingletonHandle): TSingleton;
// Single Instance function - create when first needed
var
  Index: Integer;
begin
  // Convert the handle back to an index - subtract 1
  Index := Integer(Handle) - 1;
  Assert((Index >= 0) and (Index <= SingletonInstances.Count-1));
  Assert(Assigned(SingletonClasses.List^[Index]));
  if not Assigned(SingletonInstances.List^[Index]) then
    SingletonInstances.List^[Index] := TSingletonClass(SingletonClasses.List^[Index]).SingletonCreate;
  Result := SingletonInstances.List^[Index];
end;

constructor TSingleton.SingletonCreate;
// Protected constructor
begin
  inherited Create;
end;

destructor TSingleton.SingletonDestroy;
// Protected destructor
begin
  // We cannot call inherited Destroy; here!
  // It would raise an ESingleton exception
end;

// Protected against use of default constructor
class procedure TSingleton.Create;
begin
  SingletonError;
end;

// Protected against use of Free
class procedure TSingleton.Free(Dummy: integer);
begin
  SingletonError;
end;

// Protected against use of default destructor
class procedure TSingleton.Destroy(Dummy: integer);
begin
  SingletonError;
end;

initialization
  TSingleton.Startup;
finalization
  TSingleton.Shutdown;
end.

Note that the code was written for Delphi 3 and 4 - it will give warnings on later versions (this was before the handy $IF directive and CompilerVersion constant). 

And here is a specific singleton class, that inherits the singleton functionality from the TSingleton class above.

unit HVTimeKeeper2;

interface

uses
  HVSingleton;

type
  TTimeKeeper = class(TSingleton)
  private
    function GetTime: TDateTime;
    function GetDate: TDateTime;
    function GetNow: TDateTime;
  public
    class function Instance: TTimeKeeper;
    property Time: TDateTime read GetTime;
    property Date: TDateTime read GetDate;
    property Now: TDateTime read GetNow;
  end;

function TimeKeeper: TTimeKeeper;

implementation

uses
  SysUtils;

{ TTimeKeeper }

var
  TimeKeeperHandle: TSingletonHandle;

class function TTimeKeeper.Instance: TTimeKeeper;
// Single Instance function - create when first needed
begin
  Result := TTimeKeeper(InstanceOf(TimeKeeperHandle));
end;

// Property access methods
function TTimeKeeper.GetDate: TDateTime;
begin
  Result := SysUtils.Date;
end;

function TTimeKeeper.GetNow: TDateTime;
begin
  Result := SysUtils.Now;
end;

function TTimeKeeper.GetTime: TDateTime;
begin
  Result := SysUtils.Time;
end;

// Simplified functional interface

function TimeKeeper: TTimeKeeper;
begin
  Result := TTimeKeeper.Instance;
end;

initialization
  TimeKeeperHandle := TTimeKeeper.RegisterSingletonClass(TTimeKeeper);
end.

I think the original plan was to write more articles about design patterns; general discussion, sample Delphi implementations, recognizing existing use of patterns in the VCL and so on. But they never materialized - not in print, anyway; I did stumble over a draft of patterns in the VCL. Maybe I'll revive some of that material on the blog later.

As usual you can download and read the full article (PDF) and code samples.