//******************************************************************************
//
//    Copyright © 2002 by Lucian Radulescu
//    mailto  :  lucian@ez-delphi.com
//    http    :  http://www.ez-delphi.com/
//
//******************************************************************************
//
//    Adapted singleton class from Borland Comunity
//
//    My prototype allows for inheritance, such as:
//
//      type
//
//        // TApplication
//        TApplication = class( TSingleton )
//        protected
//          procedure InitializeInstance; override;
//          procedure FinalizeInstance; override;
//        end;
//
//        // TScreen
//        TScreen = class( TSingleton )
//        protected
//          procedure InitializeInstance; override;
//          procedure FinalizeInstance; override;
//        end;
//
// all internal members (data/objects) will be created/destroyed
// in InitializeInstance / FinalizeInstance
//
//      var
//        A1, A2: TApplication;
//        S1, S2: TScreen;
//      begin
//        A1 := TApplication.Create;
//        A2 := TApplication.Create;
//        S1 := TScreen.Create;
//        S2 := TScreen.Create;
//          ... // note, my code  : A1=A2 and S1=S2 and    A1 <> S1
//        A1.Free;
//        A2.Free;
//        S2.Free;
//        S1.Free;
//      end;
//
//      To optimize the code I would suggest using this approach for
//      creation of objects inheriting from TSingleton:
//
//      function Application: TApplication;
//
//      implementation
//
//      var
//        _Application: TApplication = nil;
//
//      function Application: TApplication;
//      begin
//        if _Application = nil then
//          _Application := TApplication.Create;
//        Result := _Application;
//      end;
//        ...
//      finalization
//        if _Application <> nil then
//         _Application.Free;
//      end;
//
//    --------------------------------------------------------------------------

unit uSingle;

{$I ALLLIB.DEF}

interface

uses
  Classes;

type

// you can inherit from TSingleton and create different singleton objects
TSingleton = class
private
  FRef: Integer;
protected
  procedure InitializeInstance; virtual;
  procedure FinalizeInstance; virtual;
public
  class function NewInstance: TObject; override;
  procedure FreeInstance; override;
end;

implementation

// TSingleton ------------------------------------------------------------------
var
  Singletons: TStringList = nil;

procedure TSingleton.FreeInstance;
var
  Index: Integer;
  Instance: TSingleton;
begin
  Singletons.Find( ClassName, Index );
  Instance := TSingleton( Singletons.Objects[Index] );
  Dec( Instance.FRef );
  if Instance.FRef = 0 then
  begin
    Singletons.Delete( Index );
    Instance.FinalizeInstance;
    // at this point, Instance = Self. We want to call TObject.FreeInstance
    inherited FreeInstance;
  end;
end;

procedure TSingleton.FinalizeInstance;
begin
end;

procedure TSingleton.InitializeInstance;
begin
end;

class function TSingleton.NewInstance: TObject;
var
  Index: Integer;
begin
  if Singletons = nil then
  begin
    Singletons := TStringList.Create;
    Singletons.Sorted := true;
    Singletons.Duplicates := dupError;
  end;

  if not Singletons.Find( ClassName, Index ) then
  begin
    Result := inherited NewInstance;
    TSingleton( Result ).FRef := 1;
    TSingleton( Result ).InitializeInstance;
    Singletons.AddObject( ClassName, Result );
  end
  else
  begin
    Result := Singletons.Objects[Index];
    Inc( TSingleton( Result ).FRef );
  end;
end;

initialization
finalization
  if Singletons <> nil then
    Singletons.Free;
end.