Одиночка

Всё лучшее придумано до нас, но мы стремимся всё если не улучшить, то переделать под себя. Вот и у меня дошли руки до создания шаблона класса-одиночки (Singleton). Интересующихся подробностями отправляю в википедию: Singleton pattern (английский) и Одиночка (шаблон проектирования).
Собственно, код:

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.

Функции базового класса:

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

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

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;

Отмечу, что этот код написан для Delphi XE и в Delphi 7, например, компилироваться не будет, потребуется немного доработать его.

История создания шаблона: шаг 1.