type
TSingleton = class abstract
strict private
class var
FInstance: TSingleton;
class constructor Init;
class destructor Done;
var
FLock: LongInt;
FExists: Boolean;
protected
procedure Lock; inline;
procedure Unlock; inline;
procedure InternalCreate; virtual; abstract;
property AlreadyExists: Boolean read FExists;
public
class function NewInstance: TObject; override;
constructor Create;
procedure FreeInstance; override;
end;
////
class constructor TSingleton.Init;
begin
FInstance := nil;
end;
class destructor TSingleton.Done;
begin
if FInstance <> nil then
begin
FInstance.FExists := False;
FreeAndNil(FInstance);
end;
end;
procedure TSingleton.Lock;
begin
while Boolean(InterlockedExchange(FLock, 1)) do
ThreadSwitch;
end;
procedure TSingleton.Unlock;
begin
InterlockedExchange(FLock, 0);
end;
class function TSingleton.NewInstance: TObject;
var
Inst: TObject;
begin
if FInstance = nil then
begin
Inst := inherited NewInstance;
WriteBarrier;
if InterlockedCompareExchange(Pointer(FInstance), Pointer(Inst), nil) <> nil then
Inst.Free;
end;
Result := FInstance;
end;
constructor TSingleton.Create;
begin
Lock;
try
if AlreadyExists then
exit;
FExists := True;
InternalCreate;
finally
Unlock;
end;
end;
procedure TSingleton.FreeInstance;
begin
if AlreadyExists then
exit;
inherited;
end;