Одиночка: доработка

Здесь описывается ход доработки моего шаблона Одиночка. Первоначальный вариант кода шаблона был таким:

unit Singleton;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  strict private class var
    FInstance: TSingleton;
  private
    constructor CreateInstance;
  public
    constructor Create;
    destructor Destroy; override;
    class function Instance: TSingleton;
    class procedure DestroyInstance;
  end;

implementation

resourcestring
  // Сообщение об ошибке прямого создания экземпляра класса,
  // минуя классовый метод получения.
  E_SINGLETON_DIRECT_INSTANCE_CREATION =
    'Нельзя создавать экземпляр класса %s напрямую. ' +
    'Используйте функцию Instance';

{ TSingleton }

constructor TSingleton.Create;
begin
  raise Exception.CreateFmt(E_SINGLETON_DIRECT_INSTANCE_CREATION,
    [ClassName]);
end;

constructor TSingleton.CreateInstance;
begin
  inherited Create;

end;

destructor TSingleton.Destroy;
begin

  inherited;
end;

class procedure TSingleton.DestroyInstance;
begin
  FreeAndNil(TSingleton.FInstance);
end;

class function TSingleton.Instance: TSingleton;
begin
  if not Assigned(FInstance) then
    FInstance := CreateInstance;
  Result := FInstance;
end;

function DestroyInstances: Boolean;
begin
  TSingleton.DestroyInstance;
  Result := True;
end;

initialization
  AddTerminateProc(DestroyInstances);

end.

Этот код корректен, но имеет серьёзный недостаток: он вынуждает очень много дублировать. Каждый раз, когда необходимо создать одиночку, мы вынуждены полностью реализовывать всю логику класса, пусть вся работа и заключается в автоматической замене имени класса. Нет методу Copy-Paste!
Доработаем код шаблона, создадим базовый класс, позволяющий просто наследоваться от него.
Функции базового класса:

1. Слежение за единственностью экземпляра каждого класса наследника.
2. Уничтожение всех экземпляров наследников при завершении.

С учетом этих требований новый код получился таким:

unit Singleton;

interface

uses
  Classes, Contnrs, SysUtils;

type
  // Базовый класс одиночки.
  TSingleton = class(TObject)
  strict private class var
    FInstanceList: TObjectList;
  strict private
    class function GetInstanceList: TObjectList;
    class function GetInstance: TSingleton;
  private
    class procedure DestroyInstances;
  strict protected
    constructor CreateInstance; virtual;
  public
    constructor Create;
    procedure AfterConstruction; override;
    class function Instance: TSingleton;
  end;

implementation

resourcestring
  // Сообщение об ошибке прямого создания экземпляра класса,
  // минуя классовый метод получения.
  E_SINGLETON_DIRECT_INSTANCE_CREATION =
    'Нельзя создавать экземпляр класса %s напрямую. ' +
    'Используйте классовый метод Instance';

{ TSingleton }

procedure TSingleton.AfterConstruction;
begin
  inherited AfterConstruction;
  GetInstanceList.Add(Self);
end;

constructor TSingleton.Create;
begin
  raise Exception.CreateFmt(E_SINGLETON_DIRECT_INSTANCE_CREATION,
    [ClassName]);
end;

constructor TSingleton.CreateInstance;
begin
  inherited Create;
end;

class procedure TSingleton.DestroyInstances;
var
  InstanceList: TObjectList;
begin
  InstanceList := GetInstanceList;
  // Очищаем с конца списка.
  while InstanceList.Count > 0 do
    InstanceList.Delete(InstanceList.Count - 1);
  FreeAndNil(FInstanceList);
end;

class function TSingleton.GetInstance: TSingleton;
var
  I: Integer;
  InstanceList: TObjectList;
  Instance: TObject;
begin
  Result := nil;
  InstanceList := GetInstanceList;
  for I := 0 to InstanceList.Count - 1 do
  begin
    Instance := InstanceList.Items[I];
    if Instance.ClassType = Self then
    begin
      Result := TSingleton(Instance);
      Break;
    end;
  end;
  if not Assigned(Result) then
    Result := CreateInstance;
end;

class function TSingleton.GetInstanceList: TObjectList;
begin
  if not Assigned(FInstanceList) then
    FInstanceList := TObjectList.Create;
  Result := FInstanceList;
end;

class function TSingleton.Instance: TSingleton;
begin
  Result := GetInstance;
end;

function DestroyInstances: Boolean;
begin
  Result := True;
  TSingleton.DestroyInstances;
end;

initialization
  AddTerminateProc(DestroyInstances);

end.

Теперь для получения одиночки достаточно просто унаследоваться от базового класса:

TMySingleton = class(TSingleton);

и по необходимости доработать виртуальный конструктор CreateInstance. Также можно изменить классовый метод получения экземпляра одиночки, чтобы не приводить тип результата:

TMySingleton= class(TSingleton)
  strict protected
    constructor CreateInstance; override;
  public
    class function Instance: TMySingleton;
  end;

constructor TMySingleton.CreateInstance;
begin
  inherited CreateInstance;
end;

class function TMySingleton.Instance: TMySingleton;
begin
  Result := TMySingleton(inherited Instance);
end;