In Delphi, I want to be able to create an private object that's associated with a class, and access it from all instances of that class. In Java, I'd use:
public class MyObject {
private static final MySharedObject mySharedObjectInstance = new MySharedObject();
}
Or, if MySharedObject needed more complicated initialization, in Java I could instantiate and initialize it in a static initializer block.
(You might have guessed... I know my Java but I'm rather new to Delphi...)
Anyway, I don't want to instantiate a new MySharedObject each time I create an instance of MyObject, but I do want a MySharedObject to be accessible from each instance of MyObject. (It's actually logging that has spurred me to try to figure this out - I'm using Log4D and I want to store a TLogLogger as a class variable for each class that has logging functionality.)
What's the neatest way to do something like this in Delphi?
Here is how I'll do that using a class variable, a class procedure and an initialization block:
unit MyObject;
interface
type
TMyObject = class
private
class var FLogger : TLogLogger;
public
class procedure SetLogger(value:TLogLogger);
class procedure FreeLogger;
end;
implementation
class procedure TMyObject.SetLogger(value:TLogLogger);
begin
// sanity checks here
FLogger := Value;
end;
class procedure TMyObject.FreeLogger;
begin
if assigned(FLogger) then
FLogger.Free;
end;
initialization
TMyObject.SetLogger(TLogLogger.Create);
finalization
TMyObject.FreeLogger;
end.
Last year, Hallvard Vassbotn blogged about a Delphi-hack I had made for this, it became a two-part article:
Hack#17: Virtual class variables, Part I
Hack#17: Virtual class variables, Part II
Yeah, it's a long read, but very rewarding.
In summary, I've reused the (deprecated) VMT entry called vmtAutoTable as a variable.
This slot in the VMT can be used to store any 4-byte value, but if you want to store, you could always allocate a record with all the fields you could wish for.
TMyObject = class
private
class var FLogger : TLogLogger;
procedure SetLogger(value:TLogLogger);
property Logger : TLogLogger read FLogger write SetLogger;
end;
procedure TMyObject.SetLogger(value:TLogLogger);
begin
// sanity checks here
FLogger := Value;
end;
Note that this class variable will be writable from any class instance, hence you can set it up somewhere else in the code, usually based on some condition (type of logger etc.).
Edit: It will also be the same in all descendants of the class. Change it in one of the children, and it changes for all descendant instances.
You could also set up default instance handling.
TMyObject = class
private
class var FLogger : TLogLogger;
procedure SetLogger(value:TLogLogger);
function GetLogger:TLogLogger;
property Logger : TLogLogger read GetLogger write SetLogger;
end;
function TMyObject.GetLogger:TLogLogger;
begin
if not Assigned(FLogger)
then FLogger := TSomeLogLoggerClass.Create;
Result := FLogger;
end;
procedure TMyObject.SetLogger(value:TLogLogger);
begin
// sanity checks here
FLogger := Value;
end;
The keywords you are looking for are "class var" - this starts a block of class variables in your class declaration. You need to end the block with "var" if you wish to include other fields after it (otherwise the block may be ended by a "private", "public", "procedure" etc specifier). Eg
(Edit: I re-read the question and moved reference count into TMyClass - as you may not be able to edit the TMySharedObjectClass class you want to share, if it comes from someone else's library)
TMyClass = class(TObject)
strict private
class var
FMySharedObjectRefCount: integer;
FMySharedObject: TMySharedObjectClass;
var
FOtherNonClassField1: integer;
function GetMySharedObject: TMySharedObjectClass;
public
constructor Create;
destructor Destroy; override;
property MySharedObject: TMySharedObjectClass read GetMySharedObject;
end;
{ TMyClass }
constructor TMyClass.Create;
begin
if not Assigned(FMySharedObject) then
FMySharedObject := TMySharedObjectClass.Create;
Inc(FMySharedObjectRefCount);
end;
destructor TMyClass.Destroy;
begin
Dec(FMySharedObjectRefCount);
if (FMySharedObjectRefCount < 1) then
FreeAndNil(FMySharedObject);
inherited;
end;
function TMyClass.GetMySharedObject: TMySharedObjectClass;
begin
Result := FMySharedObject;
end;
Please note the above is not thread-safe, and there may be better ways of reference-counting (such as using Interfaces), but this is a simple example which should get you started. Note the TMySharedObjectClass can be replaced by TLogLogger or whatever you like.
Well, it's not beauty, but works fine in Delphi 7:
TMyObject = class
pulic
class function MySharedObject: TMySharedObject; // I'm lazy so it will be read only
end;
implementation
...
class function MySharedObject: TMySharedObject;
{$J+} const MySharedObjectInstance: TMySharedObject = nil; {$J-} // {$J+} Makes the consts writable
begin
// any conditional initialization ...
if (not Assigned(MySharedObjectInstance)) then
MySharedObjectInstance = TMySharedOject.Create(...);
Result := MySharedObjectInstance;
end;
I'm curently using it to build singletons objects.
For what I want to do (a private class constant), the neatest solution that I can come up with (based on responses so far) is:
unit MyObject;
interface
type
TMyObject = class
private
class var FLogger: TLogLogger;
end;
implementation
initialization
TMyObject.FLogger:= TLogLogger.GetLogger(TMyObject);
finalization
// You'd typically want to free the class objects in the finalization block, but
// TLogLoggers are actually managed by Log4D.
end.
Perhaps a little more object oriented would be something like:
unit MyObject;
interface
type
TMyObject = class
strict private
class var FLogger: TLogLogger;
private
class procedure InitClass;
class procedure FreeClass;
end;
implementation
class procedure TMyObject.InitClass;
begin
FLogger:= TLogLogger.GetLogger(TMyObject);
end;
class procedure TMyObject.FreeClass;
begin
// Nothing to do here for a TLogLogger - it's freed by Log4D.
end;
initialization
TMyObject.InitClass;
finalization
TMyObject.FreeClass;
end.
That might make more sense if there were multiple such class constants.
Two questions I think that need to be answered before you come up with a "perfect" solution..
The first, is whether TLogLogger is thread-safe. Can the same TLogLogger be called from multiple threads without calls to "syncronize"? Even if so, the following may still apply
Are class variables thread-in-scope or truly global?
If class variables are truly global, and TLogLogger is not thread safe, you might be best to use a unit-global threadvar to store the TLogLogger (as much as I don't like using "global" vars in any form), eg
Code:
interface
type
TMyObject = class(TObject)
private
FLogger: TLogLogger; //NB: pointer to shared threadvar
public
constructor Create;
end;
implementation
threadvar threadGlobalLogger: TLogLogger = nil;
constructor TMyObject.Create;
begin
if not Assigned(threadGlobalLogger) then
threadGlobalLogger := TLogLogger.GetLogger(TMyObject); //NB: No need to reference count or explicitly free, as it's freed by Log4D
FLogger := threadGlobalLogger;
end;
Edit: It seems that class variables are globally stored, rather than an instance per thread. See this question for details.
In Delphi static variables are implemented as variable types constants :)
This could be somewhat misleading.
procedure TForm1.Button1Click(Sender: TObject) ;
const
clicks : Integer = 1; //not a true constant
begin
Form1.Caption := IntToStr(clicks) ;
clicks := clicks + 1;
end;
And yes, another possibility is using global variable in implementation part of your module.
This only works if the compiler switch "Assignable Consts" is turned on, globally or with {$J+} syntax (tnx Lars).
Before version 7, Delphi didn't have static variables, you'd have to use a global variable.
To make it as private as possible, put it in the implementation section of your unit.
Related
I'm having problems with my Delphi 2006 seeming to call the incorrect constructor during dynamic creation.
I asked almost the exact same question 5 yrs ago (Why does Delphi call incorrect constructor during dynamic object creation?), and I have reviewed that. But that thread had issues of overriding virtual calls which I don't have now. I have also tried searching through StackOverflow for a matching question, but couldn't find an answer.
I am working with legacy code, so I didn't write much of this. (If you see comments below with '//kt' adding something, that is me).
The code has base class, TPCEItem as follow. Note that it does NOT have a constructor.
TPCEItem = class(TObject)
{base class for PCE items}
private
<irrelevent stuff>
public
<irrelevent stuff>
end;
Next, there is class type to use for passing a parameter (more below).
TPCEItemClass = class of TPCEItem;
Next I have a child class as follows. Note that it DOES have a contructor. The compiler will not allow me to add 'override' to this create method because the ancestor class where this is declared (TObject) does not define it as virtual.
TPCEProc = class(TPCEItem)
{class for procedures}
protected
<irrelevent stuff>
public
<irrelevent stuff>
constructor Create;
destructor Destroy; override;
end;
The code then has a function for copying data, which is a conglomeration of descendant types. Because this is older code, mosts of these lists are plain TLists or TStringLists, holding untyped pointers. Thus for each copy command a corresponding type is passed in for correct use.
procedure TPCEData.CopyPCEData(Dest: TPCEData);
begin
Dest.Clear;
<irrelevent stuff>
CopyPCEItems(FVisitTypesList, Dest.FVisitTypesList, TPCEProc); //kt added
CopyPCEItems(FDiagnoses, Dest.FDiagnoses, TPCEDiag);
CopyPCEItems(FProcedures, Dest.FProcedures, TPCEProc);
CopyPCEItems(FImmunizations, Dest.FImmunizations, TPCEImm);
CopyPCEItems(FSkinTests, Dest.FSkinTests, TPCESkin);
CopyPCEItems(FPatientEds, Dest.FPatientEds, TPCEPat);
CopyPCEItems(FHealthFactors, Dest.FHealthFactors, TPCEHealth);
CopyPCEItems(FExams, Dest.FExams, TPCEExams);
<irrelevent stuff>
end;
This CopyPCEItems is as follows:
procedure TPCEData.CopyPCEItems(Src: TList; Dest: TObject; ItemClass: TPCEItemClass);
var
AItem: TPCEItem;
i: Integer;
IsStrings: boolean;
Obj : TObject;
begin
if (Dest is TStrings) then begin
IsStrings := TRUE
end else if (Dest is TList) then begin
IsStrings := FALSE
end else begin
exit;
end;
for i := 0 to Src.Count - 1 do begin
Obj := TObject(Src[i]);
if(not TPCEItem(Src[i]).FDelete) then begin
AItem := ItemClass.Create; //<--- THE PROBLEMATIC LINE
if (Obj.ClassType = TPCEProc) and (ItemClass = TPCEProc) then begin //kt added if block and sub block below
TPCEProc(Obj).CopyProc(TPCEProc(AItem));
end else begin
AItem.Assign(TPCEItem(Src[i])); //kt <-- originally this line was by itself.
end;
if (IsStrings) then begin
TStrings(Dest).AddObject(AItem.ItemStr, AItem)
end else begin
TList(Dest).Add(AItem);
end;
end;
end;
end;
The problematic line is as below:
AItem := ItemClass.Create;
When I step through the code with the debugger, and stop on this line, an inspection of the variable ItemClass is as follows
ItemClass = TPCEProc
The problems is that the .Create is calling TObject.Create, not TPCEProc.Create, which doesn't give me an opportunity to instantiate some needed TStringLists, and later leads to access violation error.
Can anyone help me understand what is going on here? I have a suspicion that the problem is with this line:
TPCEItemClass = class of TPCEItem;
It is because this is of a class of an ancestor type (i.e. TPCEItem), that it doesn't properly carry the information for the child type (TPCEProc)?? But if this is true, then why does the debugger show that ItemClass = TPCEProc??
How can I effect a call to TPCEProc.Create?
I have been programming in Delphi for at least 30 yrs, and it frustrates me that I keep having problems with polymorphism. I have read about this repeatedly. But I keep hitting walls.
Thanks in advance.
When you are constructing objects through meta-class you need to mark its base class constructor as virtual, and if you need a constructor in any of the descendant classes they need to override that virtual constructor.
If the base class does not have a constructor, you will need to add empty one.
TPCEItem = class(TObject)
public
constructor Create; virtual;
end;
TPCEItemClass = class of TPCEItem;
TPCEProc = class(TPCEItem)
public
constructor Create; override;
destructor Destroy; override;
end;
constructor TPCEItem.Create;
begin
// if the descendant class is TObject
// or any other class that has empty constructor
// you can omit inherited call
inherited;
end;
You have already identified the problem - the base class TPCEItem does not define a virtual constructor, it just inherits a constructor from TObject, which is not virtual.
As such, you cannot create instances of any TPCEItem-derived classes by using your TPCEItemClass metaclass type. In order for a metaclass to invoke the correct derived class constructor, the base class being referred to MUST have a virtual constructor, eg:
TPCEItem = class(TObject)
...
public
constructor Create; virtual;
end;
TPCEProc = class(TPCEItem)
...
public
constructor Create; override;
...
end;
procedure TPCEData.CopyPCEItems(...; ItemClass: TPCEItemClass);
var
AItem: TPCEItem;
...
begin
...
AItem := ItemClass.Create; // <-- THIS WORKS NOW!
...
if (Obj is TPCEProc) then begin // <-- FYI: use 'is' rather than ClassType to handle descendants of TPCEProc...
TPCEProc(Obj).CopyProc(TPCEProc(AItem));
...
end;
Congratulations you have identified the problematic line
AItem := ItemClass.Create; //<--- THE PROBLEMATIC LINE
But what is wrong with this line? You are calling constructor method from existing class instance. You should not do this ever. You should only call constructor methods from specific class types not existing class instances.
So in order to fix your code change the mentioned line to
AItem := TPCEItem.Create;
You may be thinking of perhaps calling AItem := TPCEItemClass.Create; since above in your code you made next declaration
TPCEItemClass = class of TPCEItem;
This declaration does not meant that TPCEItemClass is the same type as TPCEItem but instead that both types have same type structure but they are in fact two distinct types.
By the way what is the purpose of ItemClass: TPCEItemClass parameter of your CopyPCEItems procedure if you are not even using it in your procedure but instead work with local variable AItem: TPCEItem all the time? Well at least in your shown code that is.
I would like to use Gabriel Corneanu's jpegex, a class helper for jpeg.TJPEGImage.
Reading this and this I've learned that beyond Delphi Seattle you cannot access private fields anymore like jpegex does (FData in the example below). Poking around with the VMT like David Heffernan proposed is far beyond me. Is there any easier way to get this done?
type
// helper to access TJPEGData fields
TJPEGDataHelper = class helper for TJPEGData
function Data: TCustomMemoryStream; inline;
procedure SetData(D: TCustomMemoryStream);
procedure SetSize(W,H: integer);
end;
// TJPEGDataHelper
function TJPEGDataHelper.Data: TCustomMemoryStream;
begin
Result := self.FData;
end;
Today I found a neat way around this bug using the with statement.
function TValueHelper.GetAsInteger: Integer;
begin
with Self do begin
Result := FData.FAsSLong;
end;
end;
Besides that Embarcadero did a nice job building walls to protect the private parts and that's probably why they named it 10.1 Berlin.
Beware! This is a nasty hack and can fail when the internal field structure of the hacked class changes.
type
TJPEGDataHack = class(TSharedImage)
FData: TCustomMemoryStream; // must be at the same relative location as in TJPEGData!
end;
// TJPEGDataHelper
function TJPEGDataHelper.Data: TCustomMemoryStream;
begin
Result := TJPEGDataHack(self).FData;
end;
This will only work if the parent class of the "hack" class is the same as the parent class of the original class. So, in this case, TJPEGData inherits from TSharedImage and so does the "hack" class. The positions also need to match up so if there was a field before FData in the list then an equivalent field should sit in the "hack" class, even if it's not used.
A full description of how it works can be found here:
Hack #5: Access to private fields
By using a combination of a class helper and RTTI, it is possible to have the same performance as previous Delphi versions using class helpers.
The trick is to resolve the offset of the private field at startup using RTTI, and store that inside the helper as a class var.
type
TBase = class(TObject)
private // Or strict private
FMemberVar: integer;
end;
type
TBaseHelper = class helper for TBase // Can be declared in a different unit
private
class var MemberVarOffset: Integer;
function GetMemberVar: Integer;
procedure SetMemberVar(value: Integer);
public
class constructor Create; // Executed automatically at program start
property MemberVar : Integer read GetMemberVar write SetMemberVar;
end;
class constructor TBaseHelper.Create;
var
ctx: TRTTIContext;
begin
MemberVarOffset := ctx.GetType(TBase).GetField('FMemberVar').Offset;
end;
function TBaseHelper.GetMemberVar: Integer;
begin
Result := PInteger(Pointer(NativeInt(Self) + MemberVarOffset))^;
end;
procedure TBaseHelper.SetMemberVar(value: Integer);
begin
PInteger(Pointer(NativeInt(Self) + MemberVarOffset))^ := value;
end;
As you can see it requires a bit of extra typing, but compared to patching a whole unit, it is simple enough.
I have an interface.
type IProgressObserver = interface(IInterface)
procedure ReportProgress(Progress:Integer);
procedure ReportError(Message:string);
end;
I have implemented the interface using a named class, as follows:
type TProgressObserver=class(TInterfacedObject, IProgressObserver)
procedure ReportProgress(Progress:Integer);
procedure ReportError(Message:string);
end;
... implementation of methods go here .....
addProgressObserver(TProgressObserver.Create);
Is it possible to create an instance of this interface without declaring a class? Something like this (imaginary) code, that would do the same thing as above:
addProgressObserver(IProgressObserver.Create()
begin
procedure ReportProgress(Progress:Integer)
begin
ShowMessage('Progress Observed!');
end
procedure ReportError(Message:string)
begin
Log(Message);
end
end;);
Delphi has anonymous procedures, but does it have anonymous classes??
I found this similar question, but it's in Java.
I am using Delphi 2010
You can get pretty anonymous, implementing the interface using anonymous methods. But you don't get actual compiler support for this, you'll have to declare all the anonymous method types yourself, then implement the actual "anonymous" class. Given your IProgressObserver interface, the implementation would look something like this:
type
// This is the interface we'll be dealing with.
IProgressObserver = interface(IInterface)
procedure ReportProgress(Progress:Integer);
procedure ReportError(Message:string);
end;
// This will help us anonymously create implementations of the IProgressObserver
// interface.
TAnonymousObserverImp = class(TInterfacedObject, IProgressObserver)
type
// Declare reference types for all the methods the interface needs.
TReportProgressProc = reference to procedure(Progress:Integer);
TReportErrorProc = reference to procedure(Message:string);
strict private
FReportProgressProc: TReportProgressProc;
FReportErrorProc: TReportErrorProc;
// Actual implementation of interface methods.
procedure ReportProgress(Progress:Integer);
procedure ReportError(Message:string);
// private constructor, so we'll forced to use the public "Construct" function
constructor Create(aReportProgressProc: TReportProgressProc; aReportErrorProc: TReportErrorProc);
public
// This takes the required anonymous methods as parameters and constructs an anonymous implementation
// of the IProgressObserver interface.
class function Construct(aReportProgressProc: TReportProgressProc; aReportErrorProc: TReportErrorProc): IProgressObserver;
end;
{ TAnonymousObserverImp }
class function TAnonymousObserverImp.Construct(
aReportProgressProc: TReportProgressProc;
aReportErrorProc: TReportErrorProc): IProgressObserver;
begin
// Call the private constructor
Result := TAnonymousObserverImp.Create(aReportProgressProc, aReportErrorProc);
end;
constructor TAnonymousObserverImp.Create(
aReportProgressProc: TReportProgressProc; aReportErrorProc: TReportErrorProc);
begin
inherited Create;
// We simply save the references for later use
FReportProgressProc := aReportProgressProc;
FReportErrorProc := aReportErrorProc;
end;
procedure TAnonymousObserverImp.ReportError(Message: string);
begin
// Delegate to anonymous method
FReportErrorProc(Message);
end;
procedure TAnonymousObserverImp.ReportProgress(Progress: Integer);
begin
// Delegate to anonymous method
FReportProgressProc(Progress);
end;
Once all that code is in place you'll be able to write code like this:
var i: IProgressObserver;
begin
i := TAnonymousObserverImp.Construct(
procedure (Progress:Integer)
begin
// Do something with Progress
end
,
procedure (Message:string)
begin
// Do something with Message
end
)
end;
Looks pretty anonymous to me! Given the implementation of anonymous methods in Delphi it's also fairly fast and effective.
Short answer I'm afraid: sorry, no, Delphi doesn't have anonymous classes.
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 7 years ago.
Improve this question
I know this is discussed many times everywhere i the community but I just can't find a nice and simple implementation of a Singleton Pattern in Delphi.
I have an example in C#:
public sealed class Singleton {
// Private Constructor
Singleton() { }
// Private object instantiated with private constructor
static readonly Singleton instance = new Singleton();
// Public static property to get the object
public static Singleton UniqueInstance {
get { return instance; }
}
}
I know there is no solution as elegant as this in Delphi and I saw a lot of discussion about no being able to correctly hide the constructor in Delphi (make it private) so we would need to override the NewInstance and FreeInstance methods. Something along those lines I believe is the implementation I found on ibeblog.com - "Delphi: Singleton Patterns":
type
TTestClass = class
private
class var FInstance: TTestClass;
public
class function GetInstance: TTestClass;
class destructor DestroyClass;
end;
{ TTestClass }
class destructor TTestClass.DestroyClass;
begin
if Assigned(FInstance) then
FInstance.Free;
end;
class function TTestClass.GetInstance: TTestClass;
begin
if not Assigned(FInstance) then
FInstance := TTestClass.Create;
Result := FInstance;
end;
What would be your suggestion regarding the Singleton Pattern? Can it be simple and elegant and thread safe?
Thank you.
I think if I wanted an object-like thing that didn't have any means of being constructed I'd probably use an interface with the implementing object contained in the implementation section of a unit.
I'd expose the interface by a global function (declared in the interface section). The instance would be tidied up in a finalization section.
To get thread-safety I'd use either a critical section (or equivalent) or possibly carefully implemented double-checked locking but recognising that naive implementations only work due to the strong nature of the x86 memory model.
It would look something like this:
unit uSingleton;
interface
uses
SyncObjs;
type
ISingleton = interface
procedure DoStuff;
end;
function Singleton: ISingleton;
implementation
type
TSingleton = class(TInterfacedObject, ISingleton)
private
procedure DoStuff;
end;
{ TSingleton }
procedure TSingleton.DoStuff;
begin
end;
var
Lock: TCriticalSection;
_Singleton: ISingleton;
function Singleton: ISingleton;
begin
Lock.Acquire;
Try
if not Assigned(_Singleton) then
_Singleton := TSingleton.Create;
Result := _Singleton;
Finally
Lock.Release;
End;
end;
initialization
Lock := TCriticalSection.Create;
finalization
Lock.Free;
end.
It was mentioned that i should post my answer from over here.
There is a technique called "Lock-free initialization" that does what you want:
interface
function getInstance: TObject;
implementation
var
AObject: TObject;
function getInstance: TObject;
var
newObject: TObject;
begin
if (AObject = nil) then
begin
//The object doesn't exist yet. Create one.
newObject := TObject.Create;
//It's possible another thread also created one.
//Only one of us will be able to set the AObject singleton variable
if InterlockedCompareExchangePointer(AObject, newObject, nil) <> nil then
begin
//The other beat us. Destroy our newly created object and use theirs.
newObject.Free;
end;
end;
Result := AObject;
end;
The use of InterlockedCompareExchangePointer erects a full memory barrier around the operation. It is possible one might be able to get away with InterlockedCompareExchangePointerAcquire or InterlockedCompareExchangeRelease to get away with an optimization by only having a memory fence before or after. The problem with that is:
i'm not smart enough to know if Acquire or Release semantics will work
you're constructing an object, the memory barrier performance hit is the least of your worries (it's the thread safety)
InterlockedCompareExchangePointer
Windows didn't add InterlockedCompareExchangePointer until sometime around 2003. In reality it is simply a wrapper around InterlockedCompareExchange
function InterlockedCompareExchangePointer(var Destination: Pointer; Exchange: Pointer; Comparand: Pointer): Pointer stdcall;
const
SPointerAlignmentError = 'Parameter to InterlockedCompareExchangePointer is not 32-bit aligned';
begin
{IFDEF Debug}
//On 64-bit systems, the pointer must be aligned to 64-bit boundaries.
//On 32-bit systems, the pointer must be aligned to 32-bit boundaries.
if ((NativeInt(Destination) mod 4) <> 0)
or ((NativeInt(Exchange) mod 4) <> 0)
or ((NativeInt(Comparand) mod 4) <> 0) then
begin
OutputDebugString(SPointerAlignmentError);
if IsDebuggerPresent then
Windows.DebugBreak;
end;
{ENDIF}
Result := Pointer(IntPtr(InterlockedCompareExchange(Integer(IntPtr(Destination)), IntPtr(Exchange), IntPtr(Comparand))));
end;
In XE6, i find InterlockedcompareExchangePointer implemented for 32-bit in Windows.Winapi implemented the same way (except for the safety checking):
{$IFDEF WIN32}
function InterlockedCompareExchangePointer(var Destination: Pointer; Exchange: Pointer; Comparand: Pointer): Pointer; inline;
begin
Result := Pointer(IntPtr(InterlockedCompareExchange(Integer(IntPtr(Destination)), IntPtr(Exchange), IntPtr(Comparand))));
end;
{$ENDIF}
In newer versions of Delphi you would, ideally, use the TInterlocked helper class from System.SyncObjs:
if TInterlocked.CompareExchange({var}AObject, newObject, nil) <> nil then
begin
//The other beat us. Destroy our newly created object and use theirs.
newObject.Free;
end;
Note: Any code released into public domain. No attribution required.
The trouble with Delphi is that you always inherit the Create constructor from TObject. But we can deal with that pretty nicely! Here's a way:
TTrueSingleton = class
private
class var FSingle: TTrueSingleton;
constructor MakeSingleton;
public
constructor Create;reintroduce;deprecated 'Don''t use this!';
class function Single: TTrueSingleton;
end;
As you can see we can have a private constructor and we can hide the inherited TObject.Create constructor! In the implementation of TTrueSingleton.Create you can raise an error (run-time block) and the deprecated keyword has the added benefit of providing compile-time error handling!
Here's the implementation part:
constructor TTrueSingleton.Create;
begin
raise Exception.Create('Don''t call me directly!');
end;
constructor TTrueSingleton.MakeSingleton;
begin
end;
class function TTrueSingleton.Single: TTrueSingleton;
begin
if not Assigned(FSingle) then FSingle := TTrueSingleton.MakeSingleton;
Result := FSingle;
end;
If at compile time the compiler sees you doing this:
var X: TTrueSingleton := TTrueSingleton.Create;
it will give you the deprecated warning complete with the provided error message. If you're stubborn enough to ignore it, at run time, you'll not get an object but a raised exception.
Later edit to introduce thread-safety. First of all I must confess, for my own code I don't care about this kind of thread-safety. The probability for two threads accessing my singleton creator routine within such a short time frame it causes two TTrueSingleton objects to be created is so small it's simply not worth the few lines of code required.
But this answer wouldn't be complete without thread safety, so here's my take on the issue. I'll use a simple spin-lock (busy waiting) because it's efficient when no locking needs to be done; Besides, it only locks ones
For this to work an other class var needs to be added: class var FLock: Integer. The Singleton class function should look like this:
class function TTrueSingleton.Single: TTrueSingleton;
var Tmp: TTrueSingleton;
begin
MemoryBarrier; // Make sure all CPU caches are in sync
if not Assigned(FSingle) then
begin
Assert(NativeUInt(#FLock) mod 4 = 0, 'FLock needs to be alligned to 32 bits.');
// Busy-wait lock: Not a big problem for a singleton implementation
repeat
until InterlockedCompareExchange(FLock, 1, 0) = 0; // if FLock=0 then FLock:=1;
try
if not Assigned(FSingle) then
begin
Tmp := TTrueSingleton.MakeSingleton;
MemoryBarrier; // Second barrier, make sure all CPU caches are in sync.
FSingle := Tmp; // Make sure the object is fully created when we assign it to FSingle.
end;
finally FLock := 0; // Release lock
end;
end;
Result := FSingle;
end;
There is a way to hide the inherited “Create” constructor of TObject. Although it is not possible to change the access level, it can be hidden with another public parameterless method with the same name: “Create”. This simplifies the implementation of the Singleton class tremendously. See the simplicity of the code:
unit Singleton;
interface
type
TSingleton = class
private
class var _instance: TSingleton;
public
//Global point of access to the unique instance
class function Create: TSingleton;
destructor Destroy; override;
end;
implementation
{ TSingleton }
class function TSingleton.Create: TSingleton;
begin
if (_instance = nil) then
_instance:= inherited Create as Self;
result:= _instance;
end;
destructor TSingleton.Destroy;
begin
_instance:= nil;
inherited;
end;
end.
I added the details to my original post: http://www.yanniel.info/2010/10/singleton-pattern-delphi.html
The most effective way to make sure something cannot be instantiated is by making it a pure abstract class. That is, if you care enough to heed compiler hints and warnings.
Then define a function in the implementation section that returns a reference to that abstract class. Like Cosmin does in one of his answers.
The implementation section implements that function (you can even make use of lazy instantiation here, as Cosmin also shows/ed).
But the crux is to have a concrete class declared and implemented in the implementation section of the unit so only the unit can instantiated it.
interface
type
TSingleton = class(TObject)
public
procedure SomeMethod; virtual; abstract;
end;
function Singleton: TSingleton;
implementation
var
_InstanceLock: TCriticalSection;
_SingletonInstance: TSingleTon;
type
TConcreteSingleton = class(TSingleton)
public
procedure SomeMethod; override;
end;
function Singleton: TSingleton;
begin
_InstanceLock.Enter;
try
if not Assigned(_SingletonInstance) then
_SingletonInstance := TConcreteSingleton.Create;
Result := _SingletonInstance;
finally
_InstanceLock.Leave;
end;
end;
procedure TConcreteSingleton.SomeMethod;
begin
// FLock can be any synchronisation primitive you like and should of course be
// instantiated in TConcreteSingleton's constructor and freed in its destructor.
FLock.Enter;
try
finally
FLock.Leave;
end;
end;
That said, please bear in mind that there are plenty of problems using singletons: http://jalf.dk/blog/2010/03/singletons-solving-problems-you-didnt-know-you-never-had-since-1995/
Thread safety
David is absolutely right in his comment that I was wrong before about the function not needing any protection. The instantiation does indeed need protecting or you could end up with two (possibly more) instances of the singleton and several of them in limbo with regard to freeing (which would be done in the finalization section as with many lazy instantion mechanisms). So here is the amended version.
To get thread safety in this setup, you need to protect the instantiation of the singleton and you need to protect all methods in the concrete class that are publicly available through its abstract ancestor. Other methods do not need to be protected as they are only be callable through the publicly available ones and so are protected by the protection in those methods.
You can protect this by a simple critical section, declared in the implementation, instantiated in the initialization and free in the finalization section. Of course the CS would have to protect the freeing of the singleton as well and should therefore be freed afterwards.
Discussing this with a colleague, we came up with a way to (mis)/(ab)use the instance pointer itself as a sort of lock mechanism. It would work, but I find it to ugly to share with the world at this point in time...
What synchronisation primitives are used to protect the publicly callable methods is entirely up to the "user" (coder) and may tailored to the purpose the singleton.
For threadsafety you should use a lock around the create in "TTestClass.GetInstance".
procedure CreateSingleInstance(aDestination: PPointer; aClass: TClass);
begin
System.TMonitor.Enter(Forms.Application);
try
if aDestination^ = nil then //not created in the meantime?
aDestination^ := aClass.Create;
finally
System.TMonitor.Exit(Forms.Application);
end;
end;
Threadsafe:
if not Assigned(FInstance) then
CreateSingleInstance(#FInstance, TTestClass);
And you could raise an exception in case someone tries to create it via the normal .Create (make a private constructor CreateSingleton)
I need to fix a third-party component. This component's class has private variable which is actively used by its descendants:
TThirdPartyComponentBase = class
private
FSomeVar: Integer;
public
...
end;
TThirdPartyComponent = class (TThirdPartyComponentBase)
protected
procedure Foo; virtual;
end;
procedure TThirdPartyComponent.Foo;
begin
FSomeVar := 1; // ACCESSING PRIVATE FIELD!
end;
This works because both classes are in the same unit, so they're kinda "friends".
But if I'll try to create a new class in a new unit
TMyFixedComponent = class (TThirdPartyComponent)
procedure Foo; override;
end;
I can't access FSomeVar anymore, but I need to use it for my fix. And I really don't want to reproduce in my code all that tree of base classes.
Can you advise some quick hack to access that private field without changing the original component's unit if it's possible at all?
By the use of class helpers it's possible to accomplish access to the private parts of the base class from the derived class without loosing type safety.
Just add these declarations in another unit:
Uses YourThirdPartyComponent;
type
// A helper to the base class to expose FSomeVar
TMyBaseHelper = class helper for TThirdPartyComponentBase
private
procedure SetSomeVar( value : integer);
function GetSomeVar: integer;
public
property SomeVar:integer read GetSomeVar write SetSomeVar;
end;
TMyFixedComponent = class helper for TThirdPartyComponent
protected
procedure Foo;
end;
procedure TMyFixedComponent.Foo;
begin
// Cast to base class and by the class helper TMyBaseHelper the access is resolved
TThirdPartyComponentBase(Self).SomeVar := 1;
end;
function TMyBaseHelper.GetSomeVar: integer;
begin
Result := Self.FSomeVar; // ACCESSING PRIVATE FIELD!
end;
procedure TMyBaseHelper.SetSomeVar(value: integer);
begin
Self.FSomeVar := value; // ACCESSING PRIVATE FIELD!
end;
// Testing
var
TSV: TThirdPartyComponent;
begin
TSV := TThirdPartyComponent.Create;
try
TSV.Foo;
WriteLn(IntToStr(TSV.SomeVar)); // Writes 1
finally
TSV.Free;
end;
end.
As can be seen from comments in code, FSomeVar is exposed by a class helper from the TThirdPartyComponentBase class.
Another class helper for the TThirdPartyComponent implements the Foo procedure. In there, access to the SomeVar property of the base class helper is made via a type cast to the base class.
You have to use a hack to access a private field in any class (including a base class) in a different unit. In your case define in your unit:
type
__TThirdPartyComponentBase = class
private
FSomeVar: Integer;
end;
Then get the access:
__TThirdPartyComponentBase(Self).FSomeVar := 123;
Of course, that is dangerous, because you will need to control changes in the base class. Because if the fields layout will be changed and you will miss this fact, then the above approach will lead to failures, AV's, etc.
Don't know if this will help, but I seem to recall there is a way to "crack" a private variable into visibility.
I know, for example, I've encountered warnings from the compiler when I've moved a property from lower visibility (in the base class) to a more visible level (in my descendant). The warning stated that it's being declared at a different level of visibility...
It's been some time and I'm not certain, but I believe what you can do is in your descendant declare the same variable as protected. (You may have to use the Redeclare keyword for this to compile.)
Sorry I don't have more specific information on how to do this (if it's indeed possible.) Perhaps this posting will prompt one of the wizards here into correcting me! :-)
Expose the value of the private variable by a protected property in TThirdPartyComponent.
TThirdPartyComponent = class (TThirdPartyComponentBase)
private
Procedure SetValue(Value: Integer);
Function GetValue: Integer;
protected
Property MyVar: Integer read GetValue write Setvalue;
procedure Foo; virtual;
end;
Procedure TThirdPartyComponent.SetValue(Value: Integer);
begin
FSomeVar := Value ;
end;
Function GetValue: Integer;
begin
result := FSomeVar;
end;
In TMyFixedComponent class use the MyVar Property in the procedure which you would like to override.