Change log

Home

Singleton pattern

Links

type
ISingleton = interface
['{C8D4369A-DDDC-4415-8501-5221236FCA8B}']
end;

TSingleton = class(TInterfacedObject, ISingleton)
private
ISelf: ISingleton; // to prevent dereferencing
end;

TSingletonType = class of TSingleton;

TSingletonFactory = class
protected
class function Instance(ASingletonType: TSingletonType): TSingleton;
end;


implementation

uses SysUtils;

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

var
_SingletonList: TSingletonList;
_FLock: TRTLCriticalSection;

{ TSingletonFactory }


class function TSingletonFactory.Instance(ASingletonType: TSingletonType): TSingleton;
var
_singleton: TSingleton;
Index: integer;
begin
_singleton := nil;

EnterCriticalSection(_FLock);

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

if not assigned(_singleton) then
begin
_singleton := TSingleton(ASingletonType.Create);
_singleton.ISelf := _singleton;
_SingletonList.AddObject(ASingletonType.ClassName, _singleton);
end;

LeaveCriticalSection(_FLock);

Result := _singleton as TSingleton;
end;

{ TSingletonList }

procedure TSingletonList.FreeSingletons;
var
i: integer;
_singleton: TSingleton;
begin
i := Count;
while i > 0 do // reverse order destruction, inverse of construction order.
begin
dec(i);
_singleton := TSingleton(Objects[i]);
_singleton.ISelf := nil;
end;
end;

initialization
InitializeCriticalSection(_FLock);

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

finalization

_SingletonList.FreeSingletons;
  
_SingletonList.Free;

DeleteCriticalSection(_Flock);
end.

uses
SingletonWithFactoryImpl;

type

ISingletonWithName = interface
function getName: string;
procedure setName(const AName: string);
property Name: string read getName write setName;
end;

ISingletonA = interface(ISingletonWithName)
// ISingletonA interface definitions
end;

ISingletonB = interface(ISingletonWithName)
// ISingletonB interface definitions
end;

TMySingletonFactory = class(TSingletonFactory)
public
class function singletonA: ISingletonA;
class function singletonB: ISingletonB;
end;

implementation

type
// placing the class definitions here makes them private,
// now the interfaces are the only parts publicly available
TSingletonWithName = class(TSingleton, ISingletonWithName)
private
FName: string;
function getName: string;
procedure setName(const AName: string);
public
property Name: string read getName write setName;
end;

TSingletonA = class(TSingletonWithName, ISingletonA)
// SingletonA implementation
end;

TSingletonB = class(TSingletonWithName, ISingletonB)
// SingletonB implementation
end;


{ TMySingletonFactory }

class function TMySingletonFactory.singletonA: ISingletonA;
begin
Result := Instance(TSingletonA) as TSingletonA;
end;

class function TMySingletonFactory.singletonB: ISingletonB;
begin
Result := Instance(TSingletonB) as TSingletonB;
end;

{ TSingletonWithName }

function TSingletonWithName.getName: string;
begin
Result := FName;
end;

procedure TSingletonWithName.setName(const AName: string);
begin
FName := AName;
end;

end.

function TSingletonTestForm.PerformTest: string;
var
TestSingletonA:  ISingletonA;
TestSingletonB1: ISingletonB;
TestSingletonB2: ISingletonB;
begin
TestSingletonA  := TMySingletonFactory.singletonA;
TestSingletonB1 := TMySingletonFactory.singletonB;
TestSingletonB2 := TMySingletonFactory.singletonB;

TestSingletonB2.name := 'B2';
TestSingletonB1.name := 'B1';
TestSingletonA.name  := 'A';

Result := 'value of name in A/B1/B2 - '
            + TestSingletonA.name + '/'
            + TestSingletonB1.name + '/'
            + TestSingletonB2.name;
end;

21-04-2018/18-05-2024