Change log

Home

Singleton pattern

Links

Hoewel de techniek van het overschrijven van de NewInstance en FreeInstance methods erg charmant is, is deze toch een beetje te exotisch en ook al is een com-interface niet echt iets is waar je op staat te wachten, gaat daar toch mijn voorkeur naar uit, omdat deze oplossing aanzienlijk uniformer is, vergeleken met andere omgevingen, zoals C# en Java.
Verder is het mogelijk door middel van override en reintroduce zodanig te tweaken met een Singleton zoals hier beschreven, zodat dit toch een ongemakkelijk gevoel geeft.

Een thread-safe singleton baseclass in Delphi. (versie 1)

unit SingletonImpl;

interface

uses Classes, Windows;

{---------------------------------------------
thread-safe inheritable Singleton class
---------------------------------------------}

type
TSingleton = class
private
class function MakeSingleton: TObject;
public
class function  NewInstance: TObject; override;
class procedure Lock;
class procedure Unlock;

procedure FreeInstance; override;
end;

implementation

uses SysUtils;

type
TSingletonList = class(TStringList)
public
procedure FreeSingletons;
end;

var
_SingletonList: TSingletonList;
_Finalizing: boolean;
_FLock: TRTLCriticalSection;


{ TSingleton }

procedure TSingleton.FreeInstance;
begin
if _Finalizing then
inherited;
end;

class function TSingleton.NewInstance: TObject;
begin
Result := MakeSingleton;
end;

class procedure TSingleton.Lock;
begin
EnterCriticalSection(_FLock);
end;

class procedure TSingleton.Unlock;
begin
LeaveCriticalSection(_FLock);
end;

class function TSingleton.MakeSingleton: TObject;
var
Index: integer;
NewSingleton: TObject;
begin
Lock;

NewSingleton := nil;

if _SingletonList.Find(ClassName, Index) then
NewSingleton := _SingletonList.Objects[Index];

if not assigned(NewSingleton) then
begin
NewSingleton := inherited NewInstance;
_SingletonList.AddObject(ClassName, NewSingleton);
end;

Result := NewSingleton;

Unlock;
end;

{ TSingletonList }

procedure TSingletonList.FreeSingletons;
var
i: integer;
StoredObject: TObject;
begin
_Finalizing := true;

i := Count;
while i > 0 do // reverse order destruction, opposed as to construction order.
begin
dec(i);
StoredObject := Objects[i];
if assigned(StoredObject) then
    FreeAndNil(StoredObject);
end;
end;

initialization
_Finalizing := false;

InitializeCriticalSection(_FLock);

_SingletonList := TSingletonList.Create;
_SingletonList.Sorted := true;

finalization

_SingletonList.FreeSingletons;

FreeAndNil(_SingletonList);

DeleteCriticalSection(_Flock);
end.

unit SingletonTestImpl;

interface

uses
Forms, Dialogs,

SingletonImpl;

type

TSingletonName = class(TSingleton)
public
name: string;
end;

TSingletonA = class(TSingletonName)
end;

TSingletonB = class(TSingletonName)
end;

TSingletonTestForm = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
SingletonA:  TSingletonA;
SingletonB1: TSingletonB;
SingletonB2: TSingletonB;
end;

var
SingletonTestForm: TSingletonTestForm;

implementation

{$R *.dfm}

procedure TSingletonTestForm.FormCreate(Sender: TObject);
begin
SingletonA  := TSingletonA.Create;
SingletonB1 := TSingletonB.Create;
SingletonB2 := TSingletonB.Create;

SingletonB2.name := 'B2';
SingletonB1.name := 'B1';
SingletonA.name  := 'A';

showMessage('value of name in A/B1/B2 ' 
            + SingletonA.name + '/' 
            + SingletonB1.name + '/' 
            + SingletonB2.name);
end;

end.

24-10-2017/22-11-2024