I got two classes (in my example TObject1 and TObject2) which know each other via interfaces (IObject1, IObject2). As you probably know in Delphi this will lead to a memory leak as both reference counter will always stay above zero. The usual solution is declaring one reference as weak. This works in most cases because you usually know which one will be destroyed first or don't necessarily need the object behind the weak reference once it is destroyed.
This said I tried to solve the problem in a manner that both objects stay alive until both aren't referenced anymore: (Delphi 10.1 required as I use the [unsafe] attribute)
program Project14;
{$APPTYPE CONSOLE}
uses
System.SysUtils;
type
IObject2 = interface;
IObject1 = interface
['{F68D7631-4838-4E15-871A-BD2EAF16CC49}']
function GetObject2: IObject2;
end;
IObject2 = interface
['{98EB60DA-646D-4ECF-B5A7-6A27B3106689}']
end;
TObject1 = class(TInterfacedObject, IObject1)
[unsafe] FObj2: IObject2;
constructor Create;
destructor Destroy; override;
function GetObject2: IObject2;
end;
TObject2 = class(TContainedObject, IObject2)
[unsafe] FObj1: IObject1;
constructor Create(aObj1: IObject1);
destructor Destroy; override;
end;
constructor TObject1.Create;
begin
FObj2 := TObject2.Create(Self);
end;
destructor TObject1.Destroy;
begin
TContainedObject(FObj2).Free;
inherited Destroy;
end;
function TObject1.GetObject2: IObject2;
begin
Result := FObj2;
end;
constructor TObject2.Create(aObj1: IObject1);
begin
inherited Create(aObj1);
FObj1 := aObj1;
end;
destructor TObject2.Destroy;
begin
inherited Destroy;
end;
function Test1: IObject1;
var
x: IObject2;
begin
Result := TObject1.Create;
x := Result.GetObject2;
end;
function Test2: IObject2;
var
x: IObject1;
begin
x := TObject1.Create;
Result := x.GetObject2;
end;
var
o1: IObject1;
o2: IObject2;
begin
try
o1 := Test1();
o2 := Test2();
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
This does work as it is.. function Test1 and Test2 each create one instance of TObject1 and TObject2 referencing each other and all instances get destroyed once o1 and o2 go out of scope. The solution is based on TContainedObject which forwards the refcounting to the "controller" (TObject1 in this case).
Now I know this solution has flaws, and this is where my questions start:
"TContainedObject(FObj2).Free;" smells a bit, but I don't have a better solution as I need to use an interface to reference to TObject2 (the productive code contains a few inheritance on this end). Any ideas to clean it up?
you easily forget to declare all reference between the 2 classes as weak and ..
a similar problem starts to raise with more classes: Having TObject3 which is referenced by one and references the other: memory leak. I could handle it by letting it descent from TContainedObject too but with legacy code this might not be an easy task.
I have the feeling this solution can't be applied universally and hoping for one which can - or maybe an answer that will describe why it is so hard or even impossible to have an easy to use 100%-solution to manage such situations.
Imho it can't be to complicated to have a finite amount of object which destroy each other once they are not referenced from out of their domain without having to carefully think about every reference within this domain.
Don't use unsafe
[unsafe] should not be used in normal code.
It is really a hack to the used if you don't want the compiler to do reference counting on interfaces.
Use weak instead
If for some reason you must have circular references then use a [weak] attribute on one of the references and declare the other reference as usual.
In your example it would look like this:
TParent = class(TInterfacedObject, IParent)
FChild: IChild; //normal child
constructor Create;
function GetObject2: IChild;
end;
TChild = class(TContainedObject, IChild)
//reference from the child to the parent, always [weak] if circular.
[weak] FObj1: IParent;
constructor Create(const aObj1: IParent);
end;
Now there is no need to do anything special in the destructors, so these can be omitted.
The compiler tracks all weak references and sets them to nil when the reference count of the referenced interface reaches zero.
And all this is done in a thread-safe manner.
However the weak reference itself does not increase the reference count.
When to use unsafe
This is in contrast to the unsafe reference, where no tracking and no reference counting at all takes place.
You would use an [unsafe] reference on an interfaced type that is a singleton, or one that has disabled reference counting.
Here the ref count is fixed at -1 in any case, so the calling of addref and release is an unneeded overhead.
Putting the [unsafe] eliminates that silly overhead.
Unless your interfaces override _addref and _release do not use [unsafe].
Pre Berlin alternative
Pre Berlin there is no [weak] attribute outside the NexGen compilers.
If you are running Seattle, 2010 or anything in between the following code would do {almost} the same.
Although I'm unsure if this code might not fall victim to race conditions in multithreaded code.
If that's a concern for you feel free to raise a flag and I'll investigate.
TParent = class(TInterfacedObject, IParent)
FChild: IChild; //normal child
constructor Create;
function GetObject2: IChild;
end;
TChild = class(TContainedObject, IChild)
//reference from the child to the parent, always [weak] if circular.
FObj1: TParent; //not an interface will not get refcounted.
constructor Create(const aObj1: IParent);
destructor Destroy; override;
end;
constructor TChild.Create(const aObj1: IParent);
begin
inherited Create;
FObject1:= (aObj1 as TParent);
end;
destructor TParent.Destroy;
begin
if Assigned(FChild) then FChild.InvalidateYourPointersToParent(self);
inherited;
end;
This will also ensure the interfaces get properly disposed, however now TChild.FObject1 will not automatically get nilled. You might be able to put code in the destructor of the TParent to visit all its children and inform them as in the code shown.
If one of the participants in the circular reference can't inform its weakly linked counterparts then you'll need to setup some other mechanism to nil those weak references.
If you want to keep both objects alive or dead together, the surely they are one single object. OK, I get that both may be developed by different people, so then I would make them both members of one super-object that is reference counted, like this
type
TSuperobject = class( TInterfaceObject, IObject1, iObject2 )
private
fObject1 : TObject1;
fObject2 : TObject2;
public
constructor Create;
destructor Destroy;
function GetObject2: IObject2;
etc.
end;
etc.
The details should be obvious. Any reference to object1 or object2 must reference the owning object( superobject.object1 etc.), so object1 and object2 themselves do not need to be reference counted - i.e. they can be regular objects, not interfaced objects, but it actually doesn't matter if they are reference counted because the owner will always add 1 to the reference count (in that case you may not need the destructor in the superobject). If you are leaving object1 and object2 as referenced objects make their refence to each other both weak.
You are solving the wrong problem here.
Your actual problem is not in strong - weak references nor how your solution can be improved. Your problem is not in how to achieve, but in what you are achieving (want to achieve).
To directly address your questions first:
"TContainedObject(FObj2).Free;" smells a bit, but I don't have a better solution as I need to use an interface to reference to TObject2
(the productive code contains a few inheritance on this end). Any
ideas to clean it up?
You cannot do much here. You must call Free on FObj2 because TContainedObject is not managed class itself.
you easily forget to declare all reference between the 2 classes as weak and ..
You cannot do anything here either. It comes with the territory. If you want to use ARC you have to think about circular references.
a similar problem starts to raise with more classes: Having TObject3 which is referenced by one and references the other: memory
leak. I could handle it by letting it descent from TContainedObject
too but with legacy code this might not be an easy task.
You cannot do much here either. If your design is really what you want to have, then you will just have to deal with its complexities.
Now, back to why you are having problems in the first place.
What you want to achieve (and you have done so with your example code) is keeping whole object hierarchy alive by grabbing any of the object references inside that hierarchy.
To rephrase, you have Form and a Button on it and you want to keep Form alive is something holds a Button (because Button itself would not function). Then you want to add Edit to that Form and again keep everything alive if something grabs Edit.
You have few options here.
Keep this broken design and live with your solution because you have too much code involved and change would be painful. If you do that keep in mind that this is ultimately broken design and don't attempt to repeat it anywhere else.
If you have hierarchy where TObject1 is root class that holds all else, then refactor it and inherit TObject2 from TInterfacedObject to have its own reference counting and don't grab references to FObj2. Instead grab root TObject1 instance and pass that around, if you really need to.
This is variation of second approach. If TObject1 is not the root class then create additional wrapper class containing all instances you need and pass that one around.
Last two solutions are far from perfect and they don't deal with fact that you probably have classes that are doing too much or similar. But no matter how bad that code might be, it does not even come close to your current solution. And with time you can slowly change and improve those solutions much easier than with your current one.
It looks like you want both objects to share their reference count. You could do that by letting a third object (TPair) handle the reference counting. A nice way to accomplish this is by using the implements keyword. You can choose to keep this third object hidden, or to interact with that as well.
With the code below you can either create a TPairChildA, a TPairChildB or their 'parent' TPair. Any of them will create the others when needed and all created objects will be kept alive until none are referenced anymore. You can of course add interfaces like your IObject1 to the objects, but I kept them out for simplicity.
unit ObjectPair;
interface
type
TPairChildA = class;
TPairChildB = class;
TPair = class( TInterfacedObject )
protected
FChildA : TPairChildA;
FChildB : TPairChildB;
function GetChildA : TPairChildA;
function GetChildB : TPairChildB;
public
destructor Destroy; override;
property ChildA : TPairChildA read GetChildA;
property ChildB : TPairChildB read GetChildB;
end;
TPairChild = class( TObject , IInterface )
protected
FPair : TPair;
property Pair : TPair read FPair implements IInterface;
public
constructor Create( APair : TPair = nil ); virtual;
end;
TPairChildA = class( TPairChild )
protected
function GetSibling : TPairChildB;
public
constructor Create( APair : TPair = nil ); override;
property Sibling : TPairChildB read GetSibling;
end;
TPairChildB = class( TPairChild )
protected
function GetSibling : TPairChildA;
public
constructor Create( APair : TPair = nil ); override;
property Sibling : TPairChildA read GetSibling;
end;
implementation
//==============================================================================
// TPair
destructor TPair.Destroy;
begin
FChildA.Free;
FChildB.Free;
inherited;
end;
function TPair.GetChildA : TPairChildA;
begin
if FChildA = nil then
FChildA := TPairChildA.Create( Self );
Result := FChildA;
end;
function TPair.GetChildB : TPairChildB;
begin
if FChildB = nil then
FChildB := TPairChildB.Create( Self );
Result := FChildB;
end;
// END TPair
//==============================================================================
// TPairChild
constructor TPairChild.Create( APair : TPair = nil );
begin
if APair = nil then
FPair := TPair.Create
else
FPair := APair;
end;
// END TPairChild
//==============================================================================
// TPairChildA
constructor TPairChildA.Create( APair : TPair = nil );
begin
inherited;
FPair.FChildA := Self;
end;
function TPairChildA.GetSibling : TPairChildB;
begin
Result := FPair.ChildB;
end;
// END TPairChildA
//==============================================================================
// TPairChildB
constructor TPairChildB.Create( APair : TPair = nil );
begin
inherited;
FPair.FChildB := Self;
end;
function TPairChildB.GetSibling : TPairChildA;
begin
Result := FPair.ChildA;
end;
// END TPairChildB
//==============================================================================
end.
A usage example:
procedure TForm1.Button1Click( Sender : TObject );
var
objA : TPairChildA;
ifA , ifB : IInterface;
begin
objA := TPairChildA.Create;
ifA := objA;
ifB := objA.Sibling;
ifA := nil;
ifB := nil; // This frees all three objects.
end;
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.
TMyClass = class(TObject)
private
FMyObject: TObject;
function GetMyObject: TObject;
public
property MyObject: TObject read GetMyObject write FMyObject;
end;
function TMyClass.GetMyObject: TObject;
begin
if FMyObject = nil then
FMyObject := TObject.Create;
Result := FMyObject;
end;
Sometimes, "MyObject" is not created internally but externally created and assigned to the parameter. If this object is created externally, I can not free it in this context.
Should I create a TList and Add in all objects that were created internally and destroy everything on the destructor?
How can I control the lifetime of a parameter if it is created internally or not? What you suggest to do? Is there any pattern to do this?
I'd set a flag in the Property Setter
procedure TMyClass.SetMyObject(AObject: TObject);
begin
if Assigned(MyObject) and FIsMyObject then
FMyObject.Free;
FIsMyObject := False;
FMyObject := AObject;
end;
function TMyClass.GetMyObject: TObject;
begin
if FMyObject = nil then
begin
FMyObject := TObject.Create;
FIsMyObject := True;
end;
Result := FMyObject;
end;
Destructor TMyClass.Destroy;
begin
if FIsMyObject then
FMyObject.Free;
end;
I guess the best would be to redesign your code so that this problem won't arise - this kind of ownership ambiguity is a mess.
Anyway, one option would be to use (reference counted) interfaces. This is problematic in case of circular references.
If the externally created object must not be the only reference then you could still create internal copy of the object, something like
procedure TMyClass.SetMyObject(const Value: TObject);
begin
MyObject.Assign(Value);
end;
You could assign external object to different field than internal and then you don't Free that field in destructor. Or set a flag in the property setter so that you know not to free the external object...
The two most logical and practical solutions (keep a flag, copy on assignment) are already given, but for completeness sake and since the object field isn't likely to be of the TObject type, here are three other approaches. The practicality of these depends on the type of the object field, whether you really don't want an extra boolean flag and whether you dislike to add some intelligent behavior to this construction.
(Warning: this may be a little farfetched.)
Test if the object field is of your private object type:
property MyObject: TSomeAncestor read GetMyObject write SetMyObject;
end;
implementation
type
TMyObject = class(TSomeAncestor) ... end;
destructor TMyClass.Destroy;
begin
if FMyObject is TMyObject then
FMyObject.Free;
Test on the ownership of the object field:
property MyObject: TOwnedObject read GetMyObject write SetMyObject;
end;
implementation
destructor TMyClass.Destroy;
begin
if FMyObject.Owner = Self then
FMyObject.Free;
This construction is especially useful if the external object should anyway be freed by this class: just set its Owner to this class instance. The decision depends no longer on the internal or external creation of the object.
If the object field descends from TComponent, then you do not have to free at all.
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 do not have any experience with virtual constructors which are available in Delphi. I consider to use virtual ctors in a class hierachy to reset the instance to an initial state like this:
A = class
end;
B = class(A)
end;
C = class(B)
end;
FooA = class
a_ : A;
constructor Create(inst : A); overload;
constructor Create; overload; virtual; abstract;
destructor Destroy; override;
function Bar : A;
end;
FooB = class(FooA)
b_ : B;
constructor Create; override;
constructor Create(inst : B); overload;
end;
FooC = class(FooB)
// ...
end;
{ FooA }
constructor FooA.Create(inst: A);
begin
inherited Create;
a_ := inst;
end;
destructor FooA.Destroy;
begin
FreeAndNil(a_);
inherited;
end;
function FooA.Bar : A;
begin
Result := a_;
a_ := nil;
// here comes the magic
Self.Create;
end;
{ FooB }
constructor FooB.Create;
begin
b_ := B.Create;
inherited Create(b_);
end;
constructor FooB.Create(inst: B);
begin
inherited Create(inst);
b_ := inst;
end;
{ FooC } // ...
var
fc : FooA;
baz : A;
begin
fc := FooC.Create;
baz := fc.Bar;
WriteLn(baz.ClassName);
FreeAndNil(baz);
FreeAndNil(fc);
ReadLn;
end.
Are there any problems/pitfalls in this design? The simple example works like a charm but i feel a little bit uneasy calling constructors (which do not construct anything) like this.
Edit:
I decided to move the initialization to a method in protected area with a meaningful name, what makes me feel better ;-)
FooA = class
strict private
a_ : A;
strict protected
procedure SetInst; overload; virtual; abstract;
procedure SetInst(i : A); overload;
public
constructor Create;
destructor Destroy; override;
function Foo : A;
end;
Very few classes are written to support the use of constructors as re-initializers. They usually assume that any dynamically allocated memory has not already been allocated. If you're in control of all the classes you're using, then go ahead and carefully use constructors as re-initializers.
Even if you're in control, I'd still advise against it. It's not idiomatic Delphi; anyone else reading your code (perhaps even you, a few weeks or months from now) will be confused — at least at first — by your non-standard use of constructors. It's not worth the trouble. If calling the Bar function is supposed to release ownership of the A object and create a new instance, then write functions with names that make that clear.
Rob's right about this being really weird-looking code that's likely to confuse people, and moving your code to an initialization routine is a good idea. In case you were wondering, the main purpose of virtual constructors is for something completely different: to more easily support "factory" style object creation.
Some outside source provides some data that can identify any descendant of a base class, and the factory uses a class reference and calls a virtual constructor defined in the base class on it. That way you end up with an instance of the descendant class without having to hard-code knowledge of the descendant class into the factory code.
If this sounds a bit strange, take a look at a DFM file. It's got a list of form objects that descend from TComponent, with their published properties. When the form reading code comes across an object statement, it reads the class name, looks it up in a table that maps class names to class references, and calls the virtual TComponent.Create on that class reference. This calls the virtual constructor for the actual class, and it ends up with an instance of that type of component, and starts to fill in its properties.
I recently stumbled over a problem caused by some very old code I wrote which was obviously assuming that interface references used in a with statement would be released as soon as the with-block is left - kind of like an implicit try-finally-block (similar to C#'s using-statement if I understood correctly).
Apparently (in Delphi 2009) this is not (no longer?) the case. Does anyone know when this happened? Or was my code just plain wrong to begin with?
To clarify, here's a simplified example:
type
IMyIntf = interface;
TSomeObject = class(TInterfacedObject, IMyIntf)
protected
constructor Create; override; // creates some sort of context
destructor Destroy; override; // cleans up the context created in Create
public
class function GetMyIntf: IMyIntf; //a factory method, calling the constructor
end;
procedure TestIt;
begin
DoSomething;
with (TSomeObject.GetMyIntf) do
begin
DoStuff;
DoMoreStuff;
end; // <- expected: TSomeObject gets destroyed because its ref.count is decreased to 0
DoSomethingElse;
end; // <- this is where TSomeObject.Destroy actually gets called
Whenever somebody started the old "with is evil" argument this was always the one example I had in mind which kept me going "Yes, but...". Seems like I was wrong... Can anyone confirm?
The with preserved word in Pascal/Delphi is only used for easily accessing the members of records or objects/classes (i.e. in order not to mention the record's/object's/class's name). It's very different from the C# with that relates to garbage collection. It has existed in the Pascal language since the day records were born, to simplify code calling to many data members (back then simply called "fields").
To summarize, with has nothing to do with garbage collection, release of memory or destruction of object instances. Objects that are constructed at the with header could just have been initialized in a separate code line before, it's the same.
This WITH-behavior has never changed. To reach your expected behavior you can change your code in this way:
procedure TestIt;
var
myIntf: IMyIntf;
begin
DoSomething;
myIntf := TSomeObject.GetMyIntf
DoStuff;
DoMoreStuff;
myIntf := nil; // <- here is where TSomeObject.Destroy called
DoSomethingElse;
end;
or you can do it in procedure:
procedure TestIt;
procedure DoAllStuff;
var
myIntf: IMyIntf;
begin
myIntf := TSomeObject.GetMyIntf
DoStuff;
DoMoreStuff;
end; // <- here is where TSomeObject.Destroy called
begin
DoSomething;
DoAllStuff;
DoSomethingElse;
end;