Singleton pattern
lazarus / 8-Other

----------------------------------------------------------------------
Blaazen · 2013-02-01 14:26

If someone need to apply Singleton design pattern.
Code: [Select]unit Unit2;                                 
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

type  
  { TSingleton }

  TSingleton = class sealed
  protected
    class var RefCounter: Integer;
    class constructor CreateSingleton;
    class destructor DestroySingleton;
  public
    class var Singleton: TSingleton;
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;
   
implementation

class constructor TSingleton.CreateSingleton;
begin
  RefCounter:=0;
  { comment following line will disable auto-create }
  Singleton:=TSingleton.Create;
end;

class destructor TSingleton.DestroySingleton;
begin
  { ucomment following line  if you don't want to Free Singleton
instances manually }
  //while RefCounter>0 do
    Singleton.Free;
  { or remove this class-destructor at all if you don't use the auto-
creation }
end;

procedure TSingleton.FreeInstance; 
begin
  dec(RefCounter);
  if RefCounter=0 then
    begin
      Singleton:=nil;
      inherited FreeInstance;
    end;
end;

class function TSingleton.NewInstance: TObject; 
begin
  if not assigned(Singleton) then
    begin
      Singleton:=TSingleton(inherited NewInstance);
      { initialize private variables here}
    end;
  Result:=Singleton;
  inc(RefCounter);
end;     

end.  
It is based on some delphi tutorial but I can' find the source. I'll
add it (maybe).

The code is very simple. You can create it many times but it will
point always to the same instance.
Currently, the instance is auto-created and auto-destroyed but you can
change it by commenting the relevant lines.

----------------------------------------------------------------------
taazz · 2013-02-01 14:42

looks interesting I have a question though what is the use of the
following methods

    class constructor CreateSingleton;
    class destructor DestroySingleton;

they are never called from your code but you claim that the code in
them will be executed and autocreate a TSingleton as well which I do
not understand. any documentation I could read to make things clearer?

----------------------------------------------------------------------
circular · 2013-02-01 14:52

To me, it seems a complicated way to to that.

Basically, you only need one class function to get the instance and
one class variable to store that instance.

The name NewInstance is confusing, it would be better to call it
QueryInstance and ReleaseInstance for decreasing the reference
counter.

You may also not count at all, and just call a private destructor in
"finalization" section of the unit.

----------------------------------------------------------------------
taazz · 2013-02-01 15:02

NewInstance is an existing method part of the base Tobject class which
is used internally by the creator to actually allocate and initialize
the required memory of an object by overriding it and returning the
existing object instead of a new one when the user calls
TSingleton.Create. Can't be renamed. The same reasoning applies to the
FreeInstance method but for the destruction process.

----------------------------------------------------------------------
Leledumbo · 2013-02-01 15:06

Quotethey are never called from your code but you claim that the code
in them will be executed and autocreate a TSingleton as well which I
do not understand. any documentation I could read to make things
clearer?Find Delphi documentation/article regarding this (I believe
it's not in FPC docs yet). Basically, a class constructor/destructor
will be called automatically, just like initialization/finalization
section of a unit.

----------------------------------------------------------------------
circular · 2013-02-01 15:07

@taazz: Ok, I think I get it.

In fact this code is a mix between using ref counter and no ref
counter?

----------------------------------------------------------------------
taazz · 2013-02-01 15:19

no refcounter is always used the code tries to distinguish between
auto creating the 1st singleton object or not but I do not understand
the class constructor/destructor mechanism to comment any farther on
the implementation which from a first look it seems problematic that's
why I asked for documentation.

----------------------------------------------------------------------
circular · 2013-02-01 15:29

Hehe here is how I would do a singleton :
Code: [Select]Unit Unit3;

type
  TSingletonObject = class
    ...
  end;

function SingletonObject: TSingletonObject;

implementation

var
  SingletonObjectInstance: TSingletonObject;

function SingletonObject: TSingletonObject;
begin
  if SingletonObjectInstance = nil then
    SingletonObjectInstance := TSingletonObject.Create;
  result := SingletonObjectInstance;
end;

finalization
  SingletonObjectInstance.Free;
end.

----------------------------------------------------------------------
Blaazen · 2013-02-01 15:31

@ Taazz, Circular:
Yes, it's a little mix. class constructor & class destructor are
replcement of initialization and finalization.

If you don't want the auto-create and you responsibly free all
singleton's instances (which is good habit), then you can remove class
destructor at all and use only simple class constr.:

Code: [Select]class constructor TSingleton.CreateSingleton;
begin
  RefCounter:=0;
end;
I mixed it 'cause I taken the code from my project where I wanted to
have only one instance from beginning to end of my program.
So everyone can modify it for his needs.

The source is a embarcadero website (some blog) and it is now blocked
of some reason.

----------------------------------------------------------------------
circular · 2013-02-01 15:39

For a singleton without counting, I would propose this :
Code: [Select]unit Unit2;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

type

  { TSingletonObject }

  TSingletonObject = class
  private
    class var FDestroying: boolean;
    class var FInstance: TSingletonObject;
    class function GetInstance: TSingletonObject; static;
    class destructor DestroyInstance;
  public
    constructor Create;
    destructor Destroy; override;
    class property Instance: TSingletonObject read GetInstance;
  end;

implementation

uses Dialogs;

{ TSingletonObject }

class function TSingletonObject.GetInstance: TSingletonObject; static;
begin
  if FInstance = nil then
    FInstance := TSingletonObject.Create;
  result := FInstance;
end;

class destructor TSingletonObject.DestroyInstance;
begin
  if FInstance <> nil then
  begin
    FDestroying := True;
    FInstance.Destroy;
  end;
end;

constructor TSingletonObject.Create;
begin
  MessageDlg('TSingletonObject.Create',mtInformation,[mbOk],0);
end;

destructor TSingletonObject.Destroy;
begin
  if not FDestroying then
    raise Exception.Create('You cannot destroy a singleton');
  MessageDlg('TSingletonObject.Destroy',mtInformation,[mbOk],0);
  inherited Destroy;
end;

end.

----------------------------------------------------------------------
Blaazen · 2013-02-01 15:41

@ circular (post from  04:29:59 pm )

Yes, of course, if you need it for yourself, you can do it this way.

But what is someone use you class? He will declare:
var
  SingletonObjectInstance1: TSingletonObject;
  SingletonObjectInstance2: TSingletonObject;
  SingletonObjectInstance3: TSingletonObject;

and create three new instances. And it will not be singleton anymore.
Point is that even if you declare it 1000 times and you try to create
1000 instances, all of them points to only one.
Typical usage is keyboard input or similar.

----------------------------------------------------------------------
circular · 2013-02-01 15:47

Declaring multiple variables doesn't change anything. But of course,
you could still call the Create constructor.

Ok, so how about that :
Code: [Select]unit Unit2;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

type

  { TSingletonObject }

  TSingletonObject = class
  private
    class var FCreating, FDestroying: boolean;
    class var FInstance: TSingletonObject;
    class function GetInstance: TSingletonObject; static;
    class destructor DestroyInstance;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    class property Instance: TSingletonObject read GetInstance;
  end;

implementation

uses Dialogs;

{ TSingletonObject }

class function TSingletonObject.GetInstance: TSingletonObject; static;
begin
  if FInstance = nil then
  begin
    FCreating := true;
    try
      FInstance := TSingletonObject.Create;
    finally
      FCreating := false;
    end;
  end;
  result := FInstance;
end;

class destructor TSingletonObject.DestroyInstance;
begin
  if FInstance <> nil then
  begin
    FDestroying := True;
    FInstance.Destroy;
  end;
end;

constructor TSingletonObject.Create;
begin
  if not FCreating then
    raise Exception.Create('You cannot create a singleton');
  MessageDlg('TSingletonObject.Create',mtInformation,[mbOk],0);
end;

destructor TSingletonObject.Destroy;
begin
  if not FDestroying then
    raise Exception.Create('You cannot destroy a singleton');
  MessageDlg('TSingletonObject.Destroy',mtInformation,[mbOk],0);
  inherited Destroy;
end;

end.

----------------------------------------------------------------------
circular · 2013-02-01 16:03

Following the first idea that you proposed, not counting, I would do
that :
Code: [Select]unit Unit2;
{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

type
  { TSingleton }

  TSingleton = class
  strict private
    class var FDestroying: boolean;
    class var FInstance: TSingleton;
    class destructor DestroySingleton;
  protected
    procedure Initialize; virtual;
    procedure Finalize; virtual;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;

implementation

uses Dialogs;

class destructor TSingleton.DestroySingleton;
begin
  FDestroying := True;
  FInstance.Free;
end;

procedure TSingleton.Initialize;
begin
  MessageDlg('TSingleton.Initialize',mtInformation,[mbOk],0);
end;

procedure TSingleton.Finalize;
begin
  MessageDlg('TSingleton.Finalize',mtInformation,[mbOk],0);
end;

procedure TSingleton.FreeInstance;
begin
  if FDestroying then
  begin
    Finalize;
    inherited FreeInstance;
  end;
end;

class function TSingleton.NewInstance: TObject;
begin
  if not assigned(FInstance) then
  begin
    FInstance := TSingleton(inherited NewInstance);
    FInstance.Initialize;
  end;
  Result:= FInstance;
end;

end.
You can derive this class, overriding Initialize and Finalize
functions for your needs.

----------------------------------------------------------------------
taazz · 2013-02-01 16:37

Ok after reading http://blogs.embarcadero.com/abauer/2009/09/04/38899
it seems that class constructors/destructors are executed only once
when the program is loaded/unloaded so most of my concerns are
addressed the only problem I see is in the class destructor where I
would write it like this.
Code: [Select]
class destructor TSingleton.DestroySingleton;
begin
  if Assigned(Singleton) then
    Singleton.Free;
end;



especially taking in to account the fact that the singleton variable
is set to nil before calling the inherited FreeInstance method.
Everything else seems to check out although I would remove the class
constructor completely I do not like automatic object creation
especially on initialization.

----------------------------------------------------------------------
taazz · 2013-02-01 16:50

I have noticed a Refcounter-phobia on this groups which is some what
reasonable as it does have a impact on the application speed but on
this occasion it is just a creation counter so the speed issues are so
low that they will probably not even register. It is a form garbage
collection process which is required if you want to be able to free
the object when is not used any more. I would thing that being able to
decide if the object will be kept in memory or not is something
positive and I do not see any reason to remove it.

----------------------------------------------------------------------
circular · 2013-02-01 16:56

Personally I am not refcounter phobic, I even like the idea instead of
a complete garbage collector. But in my experience, singleton classes
are used throughout the application, and if they are not, they will be
soon again. So unless you want to minimize used memory, I think it's
better to keep the instance until the program ends.

In one of my example where there is an Instance property, there is no
call to Create nor to Destroy. That's simpler.

Of course, in some cases, it is better to free the object during the
execution of the program, and there comes the refcounter-mania

----------------------------------------------------------------------
Blaazen · 2013-02-01 16:58

Taazz, yes, I agree your way of destructor is smarter.

BTW, I still keep in mind this: http://www.lazarus.freepascal.org/inde
x.php/topic,18990.msg107689.html#msg107689
I will probably need it for my long term project. I does not hurry but
on the other hand it would be nice to have it.
I'll check the suggested solutions or try to help you with yours.
I would like to do something like this but with more possible
configs.: http://the-all.org/tx81z/fm_overview.html

----------------------------------------------------------------------
taazz · 2013-02-01 17:25

@Blaazen
Oh, I haven't found the time to work on that conversion for a while I
am working on some other components which are essential at this time.

If I remember correctly the only thing left to replace before I start
testing on widget sets other than win32 is the flat scroll bars API
calls and the text drawing routines, so the conversion is at 80%.

There are a number of enhancements planed as well, I'll try to upload
everything in a sourceforge project so you can have a look as soon as
possible and I'll send you a PM when everything is online.

EDIT

This class can be inheritable if we replace the instance/singleton
class variable with a class property with virtual getter and setter
methods. this way you can override them on a child class avoiding the
need to duplicate the same code for different singleton classes.

sorry some how I lost the actual comment I started to post

----------------------------------------------------------------------
marcov · 2013-02-01 18:43

Quote from: Blaazen on February 01, 2013, 04:41:16 pm Yes, of course,
if you need it for yourself, you can do it this way.

But what is someone use you class? He will declare:
var
  SingletonObjectInstance1: TSingletonObject;
  SingletonObjectInstance2: TSingletonObject;
  SingletonObjectInstance3: TSingletonObject;

and create three new instances. And it will not be singleton anymore.
Point is that even if you declare it 1000 times and you try to create
1000 instances, all of them points to only one.
Typical usage is keyboard input or similar.

So.... How is this not a very complicated way of declararing a global
variable? :-)

----------------------------------------------------------------------
goodname · 2013-02-01 18:54

Wrote a program with a singleton a number of years ago. Think it was
in C++. At that time I discovered the easiest and if your using
threads the only safe way to do singletons is to create it when the
program starts up and destroy it when the program ends.
Code: [Select]if FInstance = nil then
// Threading interruption can happen between the test and creation.
// Could result in two singletons being created.
    FInstance := TSingletonObject.Create;

----------------------------------------------------------------------
Blaazen · 2013-02-01 19:04

Quote from: marcov on February 01, 2013, 07:43:45 pmQuote from:
Blaazen on February 01, 2013, 04:41:16 pm Yes, of course, if you need
it for yourself, you can do it this way.

But what is someone use you class? He will declare:
var
  SingletonObjectInstance1: TSingletonObject;
  SingletonObjectInstance2: TSingletonObject;
  SingletonObjectInstance3: TSingletonObject;

and create three new instances. And it will not be singleton anymore.
Point is that even if you declare it 1000 times and you try to create
1000 instances, all of them points to only one.
Typical usage is keyboard input or similar.

So.... How is this not a very complicated way of declararing a global
variable? :-)
This was reply to circular's post from "04:29:59 pm". The code he
pasted enables to create more instances of the class which is not
singleton pattern design.
My code from my original post auto-creates the instance (to class var)
which, in fact, has nothing to do with singleton itself.

----------------------------------------------------------------------
circular · 2013-02-01 19:28

Well the next codes I pasted do not allow the creation of multiple
objects. Don't stay on a failure.

----------------------------------------------------------------------
taazz · 2013-02-28 23:33

Have found some time to play with the singleton idea here I have
extended the base to be a strict abstract class allowing to create
other singletons to avoid rewriting code again and again.

Code: [Select]unit uEvsSingletonTest;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, yncobjs;

type

  { TSingleton }

  TSingleton = class abstract
  protected
    class var CreationCounter: Integer;
    class constructor CreateSingleton;
    class function NeedsNew:Boolean;virtual;
    class procedure SetInstance(aInstance:TSingleton);virtual;
    class function GetInstance:TSingleton;virtual;
    class procedure Lock;virtual;
    class procedure Unlock;virtual;

    procedure Initialize;virtual;
  public
    class function NewInstance: TObject; override;
    procedure FreeInstance; override;
  end;

  { TEvsDBApplication }

  TEvsDBApplication = class(TSingleton)
  private
    class var FInstance  : TSingleton;
    class var FDataTypes : TStringList;
    class var FLock      : TCriticalSection;
    class function GetDataTypes  (Index : Integer; Group : String) :
TObject;static;
    class procedure SetDataTypes (Index : Integer; Group : String;
aValue : TObject);static;
  protected
    class constructor AppInit;
    class destructor  AppDone;
    //the three methods below are required for the singleton to work.
    class function NeedsNew    : Boolean;      override;
    class function GetInstance : TSingleton;   override;
    class procedure SetInstance(aInstance:TSingleton);override;
    //the two below are here to make sure that this class is thread
safe if you
    // do not want to use any sync object then simple delete them and
the flock var.
    class procedure Lock;    override;
    class procedure Unlock;  override;
  public
    class property DataTypes[Index:Integer;Group:String]:TObject read
GetDataTypes write SetDataTypes;
  end;

implementation

{$REGION ' TSingleton '}

class constructor TSingleton.CreateSingleton;
begin
  CreationCounter := 0;
end;

procedure TSingleton.Initialize;
begin

end;

class function TSingleton.NeedsNew : Boolean;
begin
  Result := True;
end;

class procedure TSingleton.SetInstance(aInstance : TSingleton);
begin

end;

class function TSingleton.GetInstance : TSingleton;
begin

end;

class procedure TSingleton.Lock;
begin

end;

class procedure TSingleton.Unlock;
begin

end;

procedure TSingleton.FreeInstance;
begin
  Lock;
  try
    InterLockedDecrement(CreationCounter);
    if CreationCounter = 0 then begin
      SetInstance(nil);
      inherited FreeInstance;
    end;
  finally
    Unlock;
  end;
end;

class function TSingleton.NewInstance: TObject;
begin
  Lock;
  try
    if CompareText(ClassName, 'TSingleton') = 0 then
      raise Exception.Create('TSingleton is an Abstract class. Please
use on of the descendants');
    if NeedsNew then begin
      SetInstance(TSingleton(inherited NewInstance));
      GetInstance.Initialize;
    end;
    InterLockedIncrement(CreationCounter);
    Result := GetInstance;
  finally
    Unlock;
  end;
end;

{$ENDREGION}

{ TEvsDBApplication }

class function TEvsDBApplication.GetDataTypes(Index : Integer; Group :
String) : TObject;
begin

end;

class procedure TEvsDBApplication.SetDataTypes(Index : Integer; Group
: String;
  aValue : TObject);
begin

end;

class constructor TEvsDBApplication.AppInit;
begin
  FDataTypes := TStringList.Create;
  FLock      := TCriticalSection.Create;
end;

class destructor TEvsDBApplication.AppDone;
begin
  FDataTypes.Free;
  FLock.Free;
end;

class function TEvsDBApplication.NeedsNew : Boolean;
begin
  Result := not Assigned(FInstance);
end;

class procedure TEvsDBApplication.SetInstance(aInstance : TSingleton);
begin
  FInstance := aInstance;
end;

class function TEvsDBApplication.GetInstance : TSingleton;
begin
  Result := FInstance;
end;

class procedure TEvsDBApplication.Lock;
begin
  FLock.Enter;
end;

class procedure TEvsDBApplication.Unlock;
begin
  FLock.Leave;
end;

end.


The above unit is a small test I've created to check my ideas as you
can see each new singleton class requies to override at least 3
methods GetInstance, SetInstance & NeedsNew, to provide the singleton
variable to be used, if you use multiple threads on your application
then overriding the lock & unlock  methods is required to make thread
safe providing the syncobject youish to use in the example above I
have created a CriticalSection for demonstration purpose, I think that
this is the best choice for a singleton too.

Thank you blaazen for the inspiration.

PS. CreationCounter is used exclusively you can remove it if you like
in which case all the work above becomes meaningless, a simple class
constructor/destructor and newinstance/freeinstance override will be
better.

----------------------------------------------------------------------
circular · 2013-03-01 18:08

I think you should replace :
Code: [Select]procedure TSingleton.FreeInstance;
begin
  Lock;
  try
    InterLockedDecrement(CreationCounter);
    if CreationCounter = 0 then begin
      SetInstance(nil);
      inherited FreeInstance;
    end;
  finally
    Unlock;
  end;
end;by
Code: [Select]procedure TSingleton.FreeInstance;
var
  resultingCounter: integer;
begin
  Lock;
  try
    resultingCounter := InterLockedDecrement(CreationCounter);
    if resultingCounter = 0 then begin
      SetInstance(nil);
      inherited FreeInstance;
    end;
  finally
    Unlock;
  end;
end;

----------------------------------------------------------------------
taazz · 2013-03-01 18:21

I see your point and you are probably right.

thank you for your input.

----------------------------------------------------------------------
circular · 2013-03-01 18:50

You're welcome. Thank you too.