Реализация паттерна "Singleton" в Delphi

Давно интересовала тема реализации шаблона дизайна "Singleton" в Delphi, которая бы мне просто позволила бы мне получить соответствующее поведение путем простого наследования от некоторого базового класса. В результате нескольких различных вариантов реализаций остановился на таком:

type
  // Базовый класс для объектов, реализующих паттерн 
  // "Singleton". Для получения доступа к экземпляру
  // необходимо вызвать GetInstance. Если экземпляр 
  // еще не существует, то он будет создан. Иначе -  
  // возвращена ссылка на ранее созданный экземпляр.
  // Уничтожить экземпляр можно вручную, вызвав Free, 
  // иначе он будет уничтожен автоматически перед 
  // завершением приложения
  TSingleton = class(TObject)
  private
    class procedure RegisterInstance(Instance: 
      TSingletone);
    procedure UnRegisterInstance;
    class function FindInstance: TSingletone;
  protected
    // Инициализацию производить только в этом 
    // конструкторе, а не в GetInstance.
    // Не рекомендуется выносить этот конструктор 
    // из секции protected
    constructor Create; virtual;
  public
    class function NewInstance: TObject; override;
    procedure BeforeDestruction; override;
    // Точка доступа к экземпляру
    constructor GetInstance;
  end;
...

implementation

uses Contnrs;

var
  SingletonList: TObjectList;

{ TSingleton }

procedure TSingleton.BeforeDestruction;
begin
  UnregisterInstance;
  inherited BeforeDestruction;
end;

constructor TSingleton.Create;
begin
  inherited Create;
end;

class function TSingleton.FindInstance: 
  TSingletone;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to SingletonList.Count - 1 do
    if SingletonList[i].ClassType = Self 
    then begin
      Result := TSingleton(SingletonList[i]);
      Break;
    end;
end;

constructor TSingleton.GetInstance;
begin
  inherited Create;
end;

class function TSingleton.NewInstance: TObject;
begin
  Result := FindInstance;
  if Result = nil then begin
    Result := inherited NewInstance;
    TSingleton(Result).Create;
    RegisterInstance(TSingleton(Result));
  end;
end;

class procedure TSingleton.RegisterInstance(Instance: 
  TSingleton);
begin
  SingletonList.Add(Instance);
end;

procedure TSingletone.UnRegisterInstance;
begin
  SingletonList.Extract(Self);
end;

initialization
  SingletonList := TObjectList.Create(True);

finalization
  SingletonList.Free;

Ошибка в Delphi RTL - функция GetPropValue неверно работает с со свойствами типа Cardinal

Обнаружил неприятную ошибку в Delphi RTL. Казалось бы, такой совсем безобидный код вызывает Range check error:

type
  TFoo = class(TPersistent)
  private
    FBar: Cardinal;
  published
    property Bar: Cardinal read FBar write FBar;
  end;
...
var
  Obj: TFoo;
  Value: Variant;
begin
  Obj := TFoo.Create;
  try
    // Устанавливаем любое значение, выходящее за рамки 
    // типа Integer
    Obj.Bar := 4294967295; {$FFFFFFFF}
    Value := GetPropValue(Obj, 'Bar');
    SetPropValue(Obj, 'Bar', Value);  // Error
  finally
    Obj.Free;
  end;
end;

Почему так происходит? Заглянув в исходный код модуля TypInfo.pas, обнаружим такие строки:

  case PropInfo^.PropType^^.Kind of
    tkInteger, tkChar, tkWChar, tkClass:
      Result := GetOrdProp(Instance, PropInfo);

Очевидно, наше свойство имеет Kind = tkInteger, следовательно, Result будет присвоен результат вызова функции GetOrdProp. Казалось бы, все логично, но посмотрев на прототип функции GetOrdProp обнаружим, что возвращаемое значение имеет тип Longint - т.е. 4 байтное целое со знаком. Следовательно, вариантной переменной Result изначально установится неверное значение поля VType. Оно станет равным varInteger ($0003), вместо varLongWord ($0013). Ошибка имеет место быть именно здесь. Значение Value будет интерпретироваться как -1, а не как 4294967295.
Следующая строка в нашем примере вызовет проявление этой ошибки. Заглянув в реализацию функции SetPropValue увидим, что перед установкой свойству значения, происходит проверка, не выходит ли оно за диапазон возможных для данного типа:

function RangedValue(const AMin, AMax: Int64): Int64;
begin
  Result := Trunc(Value);
  if (Result < AMin) or (Result > AMax) then
    RangeError;
end;

Функция вызывается с верными параметрами - AMin = 0; AMax = 4294967295. Но Result в первой строке будет присвоено значение -1, т.е. наше $FFFFFFFF, которое мы установили свойству, но интерпретируемое как Integer, а не как Cardinal. И, разумеется, это значение не пройдет проверку на вхождение в диапазон.
Обходной путь для решения данной проблемы - не использовать Get(Set)PropValue для свойств, которые имеют или могут иметь тип 4-байтного целого без знака. Предусмотрите этот случай, и используйте вместо этого функции Get(Set)OrdProp.

Ручное управление временем жизни для объектов, реализующих интерфейсы

У Алексея Михайличенко, есть статья, в которой показано, что при работе с интерфейсами, которые реализуют объекты не ведущие учет ссылок, может возникнуть AV на казалось бы пустом месте. Исключение возникает в функции _IntfClear, которая вызывается автоматически для интерфейсных ссылок при выходе их за область видимости. Однако если объект до этого был уничтожен, интерфейсная ссылка перестает быть валидной и попытка вызова метода этого интерфейса собственно и приводит к AV. Вот эта статья:
http://www.delphikingdom.com/asp/viewitem.asp?catalogid=1312

В процессе обсуждения, как мне кажется, родилось решение, которое может быть использовано для своих классов, которые должны реализовать интерфейс, однако управление временем жизни объектов должно быть ручное. Вот класс, от которого в таком случае можно унаследоваться:

TMyInterfacedObject = class(TObject, IInterface)
protected
  FRefCount: Integer;
  FDestroyed: Boolean;
  function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  function _AddRef: Integer; stdcall;
  function _Release: Integer; stdcall;
public
  procedure FreeInstance; override;
end;

procedure TMyInterfacedObject.FreeInstance;
begin
  FDestroyed := True;
  if RefCount = 0 then
    inherited FreeInstance;
end; 

function TMyInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

function TMyInterfacedObject._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TMyInterfacedObject._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if (Result = 0) and FDestroyed then
    FreeInstance;
end;

При вызове Free для таких объектов освобождение памяти под экземпляр произойдет только в том случае, если равен нулю счетчик ссылок. Иначе - просто будет выполнен код деструктора, а освобождение памяти произойдет только после обнуления счетчика. С другой стороны, обнуление счетчика не приведет к уничтожению экземпляра до тех пор, пока явно не вызвать для данного объекта Free.

class constructors

Хотелось бы иметь в Delphi for Win32 методы, объявляемые как class constructor, т.е. выполняющую некоторую инициализацию для класса в целом, а не для его экземпляров. И чтобы их код гарантировано выполнялся при старте приложения (подобно секции initialization юнита). И чтобы потомки класса наследовали конструкторы класса предка, а при желании - могли переопределить его поведение. Зачем это нужно? Скажем, у меня есть классы с общим предком, которые я должен регистрировать с помощью RegisterClass. Мне приходится помнить об этом и прописывать код регистрации руками для каждого класса в секции инициализации юнита. А если бы была описанная выше возможность, я мог бы в коде классового конструктора базового класса написать
RegisterClass(Self);
и просто объявлять от класса потомков - они бы регистрировались автоматически. Можно было бы регистрировать даже более сложным образом:
RegisterClassAlias(Self, GetClassAlias);
где GetClassAlias - виртуальный классовый метод. Эх, мечты-мечты...

Порождение разнотипных объектов

Очень часто встречаю в различных проектах код, подобный представленному ниже:

сase SomeValue of
  1: Obj := TFirstClass.Create;
  2: Obj := TSecondClass.Create;
...
end;

И это еще при том, что классы родственны между собой и их конструкторы имеют одинаковый прототип. Не нужно заниматься подобной ерундой, язык поддерживает виртуальные конструкторы! Все, что нужно, это объявить тип "классовая ссылка" (он же метакласс) таким образом:
TMyClass = class of TMyObject;
где TMyObject - общий предок для всех классов, экземпляры которых необходимо создавать, а также у класса TMyObject объявить виртуальный конструктор, который в потомках следует перекрывать. Например:

TMyObject = class(...)
public
  constructor Create(SomeParam: SomeType); virtual;
...
end;
TFirstClass = class(TMyObject)
public
  constructor Create(SomeParam: SomeType); override;
...
end;

Теперь создать экземпляр неизвестного на этапе компиляции класса можно например так:

function Factory(ClassType: TMyClass; Param: SomeType): TMyObject;
begin
  Result := ClassType.Create(Param);
end;

Вызывать можно так:
Obj := Factory(TFirstClass, 10);
или
Obj := Factory(TSecondClass, 20);

Можно пойти дальше и реализовать фабрику, которая принимает на входе некое значение типа String, Integer или другого типа, находит в неком реестре сопоставленный этому значению класс и создает его экземпляр:

RegisterClassAlias(TFirstClass, '1');
RegisterClassAlias(TSecondClass, '2');

function Factory(ClassId: Integer; Param: SomeType): TMyObject;
var
  ClassType: TMyClass;
begin
  ClassType := TMyClass(FindClass(IntToStr(ClassId)));
  Result := ClassType.Create(Param);
end;

Тут мы воспользовались стандартным реестром классов, занеся в него элементы с помощью вызовов RegisterClassAlias. Ограничение этого реестра в том, что регистрировать в нем можно только потомки TPersistent. Если ваши классы не являются его потомками, то можно реализовать свой простенький реестр, на основе, скажем, TStringList

Delphi - виды контрактов у классов

Грубо говоря, видов контрактов у классов в Delphi столько, сколько и директив области видимости - private, protected, public определяют контракты класса с самим собой, с потомками и с клиентским кодом. А как быть, если нам нужна более гибкая политика разграничения доступа к членам класса? Скажем, доступ к определенным членам класса при обычных условиях клиентскому коду должен быть запрещен, однако по специальной просьбе клиента, этот доступ необходимо предоставить. Такое поведение можно реализовать с помощью интерфейсов: класс определяет нужные приватные методы как реализацию некого интерфейса. Таким образом, получить доступ к этим методам клиент сможет только явно запросив интерфейс. Этим действием клиент берет на себя ответственность, как бы подтверждая "мне это действительно нужно и я знаю, что делаю". А можно пойти еще дальше - давать доступ к интерфейсу не всем кто попросит, а делать определенную проверку и только в случае успеха возвращать интерфейс. Таким образом можно, например, сэмитировать "дружественные классы" C++. В общем, простор для творчества большой, только нужно учесть, что подобное поведение не допускается в рамках технологии COM.

Множественное наследование реализаций в Delphi

Множественное наследование реализаций - безусловно мощная, но не всегда безопасная возможность некоторых ОО-языков программирования. Есть ли в Delphi множественное наследование? На этот вопрос можно ответить просто и категорично - "Нет". Однако в качестве альтернативы, в Delphi есть множественное наследование деклараций (или интерфейсов), что также позволяет реализовать полиморфный клиентский код, работающий с неродственными объектами - т.н. "горизонтальный полиморфизм". Но как быть, когда у неродственных классов кроме общего интерфейса нужна общая реализация методов этого интерфейса? Дублировать код? Не самый лучший вариант, к тому же - есть альтернатива. В Delphi на уровне языка поддерживается делегирование реализации интерфейса стороннему классу. Таким образом, мы можем создать два или более неродственных класса, реализующих общий интерфейс, и назначить один и тот же "третий" класс ответственным за его реализацию. Как результат - наши классы имеют и общий интерфейс, и общую реализацию, причем - без дублирования кода. Вот простой пример:

// Общий интерфейс
ISomeIntf = interface
  procedure SomeProc;
end;

// Общая реализация интерфейса
TSomeIntfImpl = class(TAggregatedObject, ISomeIntf)
public
  procedure SomeProc;
end;

// Класс, наследующий интерфейс ISomeIntf с его реализацией в классе TSomeIntfImpl
TBar = class(TInterfacedObject, ISomeIntf)
private
  FSomeIntfImpl: TSomeIntfImpl;
  function GetSomeIntfImpl: ISomeIntf;
protected
  property SomeIntfImpl: ISomeIntf read GetSomeIntfImpl implements ISomeIntf;
public
  constructor Create;
  destructor Destroy; override;
end;

...

constructor TBar.Create;
begin
  inherited Create;
  FSomeIntfImpl := TSomeIntfImpl.Create(Self);
end;

destructor TBar.Destroy;
begin
  FSomeIntfImpl.Free;
  inherited Destroy;
end;

function TBar.GetSomeIntfImpl: ISomeIntf;
begin
  Result := FSomeIntfImpl;
end;

Таким образом, класс TBar наследует интерфейс ISomeIntf и делегирует его реализацию классу TSomeIntfImpl. Таким же образом, мы можем создать и другие классы, кроме TBar, и писать для них полиморфный код, имея на руках ссылку на интерфейс ISomeIntf.
TSomeIntfImpl объявлен как потомок TAggregatedObject. Это важно, так как в этом классе методы интерфейса IInterface реализованы таким образом, что просто передают вызовы внешнему объекту. Если бы TSomeIntfImpl сам реализовал эти методы, то клиент не смог бы, имея на руках ссылку на ISomeIntf получить другой интерфейс, даже если класс TBar его и поддерживал. Кроме того, при запросе ISomeIntf счетчик ссылок увеличивался бы не у экземпляра TBar, как следовало бы, а у внутреннего объекта класса TSomeIntfImpl.