Mega Code Archive
A real singleton class implementation (Part II)
<![CDATA[
Title: A real singleton class implementation (Part II)
Question: How to implement a real singleton class that can have only one instance.
Answer:
See my previous ID 2311 for the first method.
With this second method singleton is totally protected :)
Exemple below change the application exception to debug handler.
Interface IDebug give access to object specified and created in implementation at startup and deactivate by default.
Thanks to Peter Morris (mailto:pete@stuckindoors.com) for the idea !
// **************************************************************************
// * Implementation of a real Delphi singleton object *
// * by using interface *
// **************************************************************************
unit U_Singleton;
interface
uses
SysUtils;
type
IDebug = interface(IUnknown)
function GetInstance : IDebug;
function IsActive : boolean;
procedure SetActive(Value : boolean);
procedure ShowException(Sender: TObject; E : Exception);
end;
function GetDebug : IDebug;
implementation
uses
Dialogs, Forms, Classes;
type
TDebug = class(TObject, IDebug)
private
FOldHandler : TExceptionEvent;
FActive : boolean;
private
function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
protected
procedure HandleException(Sender: TObject; E: Exception); virtual;
public
constructor Create;
destructor Destroy; override;
function GetInstance : IDebug;
function IsActive : boolean;
procedure SetActive(Value : boolean);
procedure ShowException(Sender: TObject; E : Exception);
end;
var
Debug : IDebug;
//------------------------------------------
function GetDebug : IDebug;
begin
result := Debug;
end;
//------------------------------------------
constructor TDebug.Create;
begin
// Do what to do
end;
//------------------------------------------
destructor TDebug.Destroy;
begin
// Do what to do
SetActive(false);
inherited;
end;
//------------------------------------------
function TDebug.GetInstance;
begin
result := self;
end;
//------------------------------------------
function TDebug.QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
begin
end;
//------------------------------------------
function TDebug._AddRef: Integer; stdcall;
begin
end;
//------------------------------------------
function TDebug._Release: Integer; stdcall;
begin
end;
//------------------------------------------
procedure TDebug.HandleException(Sender: TObject; E: Exception);
begin
Showexception(Sender, E);
end;
//------------------------------------------
function TDebug.IsActive : boolean;
begin
result := FActive;
end;
//------------------------------------------
procedure TDebug.SetActive(Value : boolean);
begin
if (FActive = Value) then Exit;
case (Value) of
True : begin
FOldHandler := Application.OnException;
Application.OnException := HandleException;
end;
False : Application.OnException := FOldHandler;
end;
FActive := Value;
end;
//------------------------------------------
procedure TDebug.ShowException(Sender: TObject; E : Exception);
var s : string;
begin
if Assigned(Sender) then s := 'Except send by ' + Sender.ClassName + ' : ';
MessageDlg(s + E.Message, mtError, [mbOK], 0);
end;
//------------------------------------------
initialization
try
Debug := TDebug.Create;
except
on E : Exception do MessageDlg(E.Message, mtError, [mbOK], 0);
end;
finalization
// Let's cleaning process by Windows...
end.
]]>