Due to the lack of multiple inheritance in Delphi, I need to work with interface delegation. This is a very new topic to me and I have a problem with combining overridding with interface delegation.
The class TMyNode must inherit from TBaseClass and needs to implement IAddedStuff . I want to have the default implementation of all functions of IAddedStuff in TAddedStuffDefaultImplementation , so I don't need to have duplicate code for getters/setters everywhere. So, I have delegated those things using DefaultBehavior .
The problem is, that TAddedStuffDefaultImplementation is meant to have virtual methods, so I want to override them directly in TMyNode . This does work if I write FDefaultImplementation: TAddedStuffDefaultImplementation; instead of FDefaultImplementation: IAddedStuff; .
But now, for some reasons TAddedStuffDefaultImplementation will increase the Ref-Counter for x: TBaseClass;, so it cannot be freed. What should I do?
My simplified reproduction code is below:
program Project2;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils;
type
IAddedStuff = interface(IInterface)
['{9D5B00D0-E317-41A7-8CC7-3934DF785A39}']
function GetCaption: string; {virtual;}
end;
TAddedStuffDefaultImplementation = class(TInterfacedObject, IAddedStuff)
function GetCaption: string; virtual;
end;
TBaseClass = class(TInterfacedObject);
TMyNode = class(TBaseClass, IAddedStuff)
private
FDefaultImplementation: TAddedStuffDefaultImplementation;
public
property DefaultBehavior: TAddedStuffDefaultImplementation read FDefaultImplementation
write FDefaultImplementation implements IAddedStuff;
destructor Destroy; override;
// -- IAddedStuff
// Here are some functions which I want to "override" in TMyNode.
// All functions not declared here, should be taken from FDefaultImplementation .
function GetCaption: string; {override;}
end;
{ TAddedStuffDefaultImplementation }
function TAddedStuffDefaultImplementation.GetCaption: string;
begin
result := 'PROBLEM: CAPTION NOT OVERRIDDEN';
end;
{ TMyNode }
destructor TMyNode.Destroy;
begin
if Assigned(FDefaultImplementation) then
begin
FDefaultImplementation.Free;
FDefaultImplementation := nil;
end;
inherited;
end;
function TMyNode.GetCaption: string;
begin
Result := 'OK: Caption overridden';
end;
var
x: TBaseClass;
gn: IAddedStuff;
s: string;
begin
x := TMyNode.Create;
try
TMyNode(x).DefaultBehavior := TAddedStuffDefaultImplementation.Create;
Assert(Supports(x, IAddedStuff, gn));
WriteLn(gn.GetCaption);
finally
WriteLn('RefCount = ', x.RefCount);
// x.Free; // <-- FREE fails since FRefCount is 1
end;
ReadLn(s);
end.
If you are delegating the IAddedStuff then you should also implement non-default behavior on another class and pass it by constructor injection.
Also if you are mixing object and interface references, make sure the ref counting does not conflict. When using interface delegation the reference of the container object gets changed.
program Project1;
{$APPTYPE CONSOLE}
uses
Classes,
SysUtils;
type
IAddedStuff = interface(IInterface)
['{9D5B00D0-E317-41A7-8CC7-3934DF785A39}']
function GetCaption: string; {virtual;}
end;
TAddedStuffDefaultImplementation = class(TInterfacedObject, IAddedStuff)
function GetCaption: string; virtual;
end;
TAddedStuffOverriddenImplementation = class(TAddedStuffDefaultImplementation)
function GetCaption: string; override;
end;
TBaseClass = class(TInterfacedPersistent);
TMyNode = class(TBaseClass, IAddedStuff)
private
FAddedStuff: IAddedStuff;
property AddedStuff: IAddedStuff read FAddedStuff implements IAddedStuff;
public
constructor Create(const addedStuff: IAddedStuff);
end;
{ TAddedStuffDefaultImplementation }
function TAddedStuffDefaultImplementation.GetCaption: string;
begin
result := 'PROBLEM: CAPTION NOT OVERRIDDEN';
end;
{ TAddedStuffOverriddenImplementation }
function TAddedStuffOverriddenImplementation.GetCaption: string;
begin
Result := 'OK: Caption overridden';
end;
{ TMyNode }
constructor TMyNode.Create;
begin
FAddedStuff := addedStuff;
end;
var
x: TBaseClass;
gn: IAddedStuff;
begin
x := TMyNode.Create(TAddedStuffOverriddenImplementation.Create);
try
Assert(Supports(x, IAddedStuff, gn));
WriteLn(gn.GetCaption);
finally
x.Free;
end;
Readln;
ReportMemoryLeaksOnShutdown := True;
end.
Edit:
After the discussion in the comments I would suggest the following:
program Project1;
{$APPTYPE CONSOLE}
uses
Classes,
SysUtils;
type
IAddedStuff = interface(IInterface)
['{9D5B00D0-E317-41A7-8CC7-3934DF785A39}']
function GetCaption: string;
end;
TAddedStuffDefaultImplementation = class(TInterfacedObject, IAddedStuff)
function GetCaption: string; virtual;
end;
TBaseClass = class(TInterfacedPersistent);
TMyNode = class(TBaseClass, IAddedStuff)
private
FAddedStuff: IAddedStuff;
property AddedStuff: IAddedStuff read FAddedStuff implements IAddedStuff;
public
constructor Create;
end;
TAddedStuffOverriddenImplementation = class(TAddedStuffDefaultImplementation)
private
FMyNode: TMyNode;
public
constructor Create(AMyNode: TMyNode);
function GetCaption: string; override;
end;
{ TAddedStuffDefaultImplementation }
function TAddedStuffDefaultImplementation.GetCaption: string;
begin
result := 'PROBLEM: CAPTION NOT OVERRIDDEN';
end;
{ TMyNode }
constructor TMyNode.Create;
begin
FAddedStuff := TAddedStuffOverriddenImplementation.Create(Self);
end;
{ TAddedStuffOverriddenImplementation }
constructor TAddedStuffOverriddenImplementation.Create(AMyNode: TMyNode);
begin
FMyNode := AMyNode;
end;
function TAddedStuffOverriddenImplementation.GetCaption: string;
begin
Result := 'OK: Caption overridden';
end;
var
x: TBaseClass;
gn: IAddedStuff;
begin
x := TMyNode.Create;
try
Assert(Supports(x, IAddedStuff, gn));
WriteLn(gn.GetCaption);
finally
x.Free;
end;
ReadLn;
ReportMemoryLeaksOnShutdown := True;
end.
Related
Suppose I have an ancestor class (TMyAncestorClass), an enumerated type (TMyType) and some descendants class (TDesc1, TDesc2, TDesc3...)
type TMytype = (ta, tb, tc);
TMyAncestorClass= class
procedure DoSomething;
end;
TDesc1 = class(TMyAncestorClass)
end;
TDesc2 = class(TMyAncestorClass)
end;
TDesc3 = class(TMyAncestorClass)
end;
function CreateMyClass(aMyType: TMyType): TMyAncestorClass;
begin
case aMyType of
ta: Result := TDesc1.Create;
tb: Result := TDesc2.Create;
tc: Result := TDesc3.Create;
else
Result := nil; // or throw an exception
end;
end;
I want to refactor it. What is the best design pattern or solution for it? Now every time a new type is added I have to modify a CreateMyClass function too.
You could get rid of the enum completely by simply having CreateMyClass() take an integer instead, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
procedure DoSomething; virtual; abstract;
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
type
TDesc1 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
procedure DoSomething; override;
end;
...
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
begin
case aMyType of
1: Result := TDesc1.Create;
2: Result := TDesc2.Create;
3: Result := TDesc3.Create;
else
Result := nil; // or throw an exception
end;
end;
end.
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(1, 2, 3, ...);
try
Obj.DoSomething;
finally
Obj.Free;
end;
end;
You could simplify that a little by using an array of class types, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
constructor Create; virtual; // <-- add this
procedure DoSomething; virtual; abstract;
end;
TMyAncestorClassType = class of TMyAncestorClass;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
type
TDesc1 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
...
constructor TMyAncestorClass.Create;
begin
inherited;
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
const
Types: array[1..3] of TMyAncestorClassType = (
TDesc1,
TDesc2,
TDesc3
);
begin
if aMyType >= Low(Types) and aMyType <= High(Types) then
Result := Types[aMyType].Create
else
Result := nil; // or throw an exception
end;
end.
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(1, 2, 3, ...);
try
Obj.DoSomething;
finally
Obj.Free;
end;
end;
Of course, this does mean you are still having to edit CreteMyClass() each time a new class is introduced. So, if you want something more dynamic, you will need to add a registration system at runtime, for example by storing class types in a lookup table like TDictionary, eg:
unit MyClasses;
interface
type
TMyAncestorClass = class
constructor Create; virtual;
procedure DoSomething; virtual; abstract;
end;
TMyAncestorClassType = class of TMyAncestorClass;
function RegisterMyClass(aClass: TMyAncestorClassType): Integer;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
implementation
uses
System.Generics.Collections;
var
RegisteredClasses: TDictionary<Integer, TMyAncestorClassType>;
Counter: Integer = 0;
constructor TMyAncestorClass.Create;
begin
inherited;
end;
function RegisterMyClass(aClass: TMyAncestorClassType): Integer;
begin
Result := Counter;
Inc(Counter);
RegisteredClasses.Add(Result, aClass);
end;
function CreateMyClass(aMyType: Integer): TMyAncestorClass;
var
LClass: TMyAncestorClassType;
begin
if RegisteredClasses.TryGetValue(aMyType, LClass) then
Result := LClass.Create
else
Result := nil; // or throw an exception
end;
initialization
RegisteredClasses := TDictionary<Integer, TMyAncestorClassType>.Create;
finalization
RegisteredClasses.Free;
end.
uses
..., MyClasses;
type
TDesc1 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc2 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
TDesc3 = class(TMyAncestorClass)
constructor Create; override; // if needed
procedure DoSomething; override;
end;
...
...
var
Desc1Type: Integer;
Desc2Type: Integer;
Desc3Type: Integer;
...
...
var
Obj: TMyAncestorClass;
begin
Obj := CreateMyClass(Desc1Type, Desc2Type, Desc3Type, ...);
...
Obj.Free;
end;
...
initialization
Desc1Type := RegisterMyClass(TDesc1);
Desc2Type := RegisterMyClass(TDesc2);
Desc3Type := RegisterMyClass(TDesc3);
Instead of an enumerated type, simply use the class type:
TMyType = class of TMyAncestorClass;
Then your function becomes trivial:
function CreateMyClass(aMyType: TMyType): TMyAncestorClass;
begin
Result := TMyType.Create;
end;
You call it like this:
var
X : TMyAncestroClass;
begin
X := CreateMyClass(TDesc1);
end;
Of course this is somewhat useless as is. But I guess you have a lot of other code in CreateMyClass(). BTW: I would have named it MyClassFactory.
Edit:
If you really need an enumerated type, then use the following additional code:
type
TMyTypeEnum = (ta, tb, tc);
const
MyTypes : array [TMyTypeEnum] of TMyType = (TDesc1, TDesc2, TDesc3);
The class factory is then:
function MyClassFactory(aMyType : TMyTypeEnum) : TMyAncestorClass;
begin
Result := MyTypes[aMyType].Create;
end;
And call it like this:
var
X : TMyAncestroClass;
begin
X := MyClassFactory(tb);
end;
I am reading Hodges book "More Coding in Delphi", section on Factory Pattern. I come up with a problem. I need to implement Init procedures for each descendant of TBaseGateway class. The problem is I do not know how to pass correct record type. Is there any nice solution?
unit Unit2;
interface
uses
Generics.Collections, System.SysUtils, System.Classes, Dialogs;
type
TGatewayTpe = (gtSwedbank, gtDNB);
type
IGateway = interface
['{07472665-54F5-4868-B4A7-D68134B9770B}']
procedure Send(const AFilesToSend: TStringList);
end;
type
TBaseGateway = class(TAggregatedObject, IGateway)
public
procedure Send(const AFilesToSend: TStringList); virtual; abstract;
end;
type
TSwedbankGateway = class(TBaseGateway)
public
// procedure Init(const ASwedbanRecord: TSwedBankRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TDNBGateway = class(TBaseGateway)
public
// procedure Init(const ADNBRecord: TDNBRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TGatewayFunction = reference to function: TBaseGateway;
type
TGatewayTypeAndFunction = record
GatewayType: TGatewayTpe;
GatewayFunction: TGatewayFunction;
end;
type
TGatewayFactory = class
strict private
class var FGatewayTypeAndFunctionList: TList<TGatewayTypeAndFunction>;
public
class constructor Create;
class destructor Destroy;
class procedure AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
end;
implementation
class procedure TGatewayFactory.AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
var
_GatewayTypeAndFunction: TGatewayTypeAndFunction;
begin
_GatewayTypeAndFunction.GatewayType := AGatewayType;
_GatewayTypeAndFunction.GatewayFunction := AGatewayFunction;
FGatewayTypeAndFunctionList.Add(_GatewayTypeAndFunction);
end;
class constructor TGatewayFactory.Create;
begin
FGatewayTypeAndFunctionList := TList<TGatewayTypeAndFunction>.Create;
end;
class destructor TGatewayFactory.Destroy;
begin
FreeAndNil(FGatewayTypeAndFunctionList);
end;
procedure TSwedbankGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
procedure TDNBGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
initialization
TGatewayFactory.AddGateway(gtDNB,
function: TBaseGateway
begin
Result := TDNBGateway.Create(nil);
end);
TGatewayFactory.AddGateway(gtSwedbank,
function: TBaseGateway
begin
Result := TSwedbankGateway.Create(nil);
end);
end.
Is it possible to inspect the RTTI information for an instance of a generic type with an interface type constraint? The question is probably a little ambiguous so I've created a sample console app to show what I'm trying to do:
program Project3;
{$APPTYPE CONSOLE}
uses
RTTI,
SysUtils,
TypInfo;
type
TMyAttribute = class(TCustomAttribute)
strict private
FName: string;
public
constructor Create(AName: string);
property Name: string read FName;
end;
IMyObjectBase = interface
['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
procedure DoSomething;
end;
TMyObjectBase = class(TInterfacedObject, IMyObjectBase)
public
procedure DoSomething; virtual;
end;
[TMyAttribute('First')]
TMyFirstRealClass = class(TMyObjectBase)
public
procedure DoSomethingDifferent;
end;
[TMyAttribute('Second')]
TMySecondRealClass = class(TMyObjectBase)
public
procedure BeSomethingDifferent;
end;
TGenericClass<I: IMyObjectBase> = class
public
function GetAttributeName(AObject: I): string;
end;
{ TMyAttribute }
constructor TMyAttribute.Create(AName: string);
begin
FName := AName;
end;
{ TMyObjectBase }
procedure TMyObjectBase.DoSomething;
begin
end;
{ TMyFirstRealClass }
procedure TMyFirstRealClass.DoSomethingDifferent;
begin
end;
{ TMySecondRealClass }
procedure TMySecondRealClass.BeSomethingDifferent;
begin
end;
{ TGenericClass<I> }
function TGenericClass<I>.GetAttributeName(AObject: I): string;
var
LContext: TRttiContext;
LProp: TRttiProperty;
LAttr: TCustomAttribute;
begin
Result := '';
LContext := TRttiContext.Create;
try
for LAttr in LContext.GetType(AObject).GetAttributes do
// ----> [DCC Error] E2250 There is no overloaded version of 'GetType' that can be called with these arguments
if LAttr is TMyAttribute then
begin
Result := TMyAttribute(LAttr).Name;
Break;
end;
finally
LContext.Free;
end;
end;
var
LFirstObject: IMyObjectBase;
LSecondObject: IMyObjectBase;
LGeneric: TGenericClass<IMyObjectBase>;
begin
try
LFirstObject := TMyFirstRealClass.Create;
LSecondObject := TMySecondRealClass.Create;
LGeneric := TGenericClass<IMyObjectBase>.Create;
Writeln(LGeneric.GetAttributeName(LFirstObject));
Writeln(LGeneric.GetAttributeName(LSecondObject));
LGeneric.Free;
LFirstObject := nil;
LSecondObject := nil;
Readln;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
I need to inspect the object being passed in (AObject), not the generic interface (I).
(Dephi 2010).
Thanks for any advice.
Two possible solutions for this is as follows:
1) I tested with this and it works (XE4):
for LAttr in LContext.GetType((AObject as TObject).ClassType).GetAttributes do
2) I tested with this and it works (XE4):
for LAttr in LContext.GetType(TMyObjectBase(AObject).ClassType).GetAttributes do
3) Create method on the interface that returns the object and use that to inspect the object:
IMyObjectBase = interface
['{E063AD44-B7F1-443C-B9FE-AEB7395B39DE}']
procedure DoSomething;
function GetObject: TObject;
end;
TMyObjectBase = class(TInterfacedObject, IMyObjectBase)
public
procedure DoSomething; virtual;
function GetObject: TObject;
end;
{ TMyObjectBase }
function TMyObjectBase.GetObject: TObject;
begin
Result := Self;
end;
And then call it like this:
for LAttr in LContext.GetType(AObject.GetObject.ClassType).GetAttributes do
This is a follow up to this post.
I refined my requirement based on the accepted answer posted here.
My *.dpr file:
program DuckD11;
{$APPTYPE CONSOLE}
uses
SysUtils,
uDuckTyping in 'uDuckTyping.pas',
uBirds in 'uBirds.pas';
procedure DoSomething(AObject: TObject);
begin
Duck(AObject).Quack;
end;
var
Bird: TBird;
Ganagana: TGanagana;
Canard: TCanard;
begin
Writeln('Duck typing :');
Writeln;
Bird := TBird.Create('Bird');
try
DoSomething(Bird);
finally
Bird.Free;
end;
Ganagana := TGanagana.Create;
try
DoSomething(Ganagana);
finally
Ganagana.Free;
end;
Canard := TCanard.Create;
try
DoSomething(Canard);
finally
Canard.Free;
end;
Readln;
end.
uBirds.pas listing:
unit uBirds;
interface
uses
SysUtils;
type
{$METHODINFO ON}
TBird = class
private
FName: string;
public
constructor Create(AName: string);
procedure Quack;
end;
TGanagana = class
private
const cName = 'Ganagana';
public
procedure Quack;
end;
TCanard = class
private
const cName = 'Canard';
public
procedure Quack;
end;
{$METHODINFO OFF}
implementation
{ TBird }
constructor TBird.Create(AName: string);
begin
FName := AName;
end;
procedure TBird.Quack;
begin
Writeln(Format(' %s->Quack',[Self.FName]));
end;
{ TGanagana }
procedure TGanagana.Quack;
begin
Writeln(Format(' %s=>Quack',[Self.cName]));
end;
{ TCanard }
procedure TCanard.Quack;
begin
Writeln(Format(' %s::Quack',[Self.cName]));
end;
end.
My attempt coding uDuckTyping.pas:
unit uDuckTyping;
interface
type
IDuck = interface
['{41780389-7158-49F7-AAA5-A4ED5AE2699E}']
procedure Quack;
end;
function Duck(AObject: TObject): IDuck;
implementation
uses
ObjAuto;
type
TDuckObject = class(TInterfacedObject, IDuck)
private
FObj: TObject;
// ???
protected
procedure Quack;
public
constructor Create(AObject: TObject);
end;
function Duck(AObject: TObject): IDuck;
begin
Result := TDuckObject.Create(AObject);
end;
{ TDuckObject }
constructor TDuckObject.Create(AObject: TObject);
begin
FObj := AObject;
// ???
end;
procedure TDuckObject.Quack;
begin
// ???
end;
end.
My question:
I want to use
ObjAuto.GetMethodInfo to ascertain the existence of the wrapped Quack method.
ObjAuto.ObjectInvoke to invoke the wrapped Quack method.
How can I complete the code ?
I end up getting it to work after many trial:
Modifications in the uDucktyping.pas unit:
Fields added as private in TDuckObject class definition
FQuackPMethodInfo: PMethodeInfoHeader;
FParamIndexes: array of Integer;
FParams: array of Variant;
Initialization of FQuackPMethodInfo in TDuckObject.Create implementation
FQuackPMethodInfo := GetMethodInfo(AObject, ShortString('Quack'));
To append just after FObj initialization statement.
Invokation of "Quack" within TDuckObject.Quack implementation
if Assigned(FQuackPMethodInfo) then
ObjectInvoke(FObj, FQuackPMethodInfo, FParamIndexes, FParams);
When working with lists of items where the lists just serve as a temporary container - which list types would you recommend me to use?
I
don't want to destroy the list manually
would like to use a built-in list type (no frameworks, libraries, ...)
want generics
Something which would make this possible without causing leaks:
function GetListWithItems: ISomeList;
begin
Result := TSomeList.Create;
// add items to list
end;
var
Item: TSomeType;
begin
for Item in GetListWithItems do
begin
// do something
end;
end;
What options do I have? This is about Delphi 2009 but for the sake of knowledge please also mention if there is something new in this regard in 2010+.
An (somehow ugly) workaround for this is to create an 'autodestroy' interface along with the list. It must have the same scope so that when the interface is released, your list is destroyed too.
type
IAutoDestroyObject = interface
end;
TAutoDestroyObject = class(TInterfacedObject, IAutoDestroyObject)
strict private
FValue: TObject;
public
constructor Create(obj: TObject);
destructor Destroy; override;
end;
constructor TAutoDestroyObject.Create(obj: TObject);
begin
inherited Create;
FValue := obj;
end;
destructor TAutoDestroyObject.Destroy;
begin
FreeAndNil(FValue);
inherited;
end;
function CreateAutoDestroyObject(obj: TObject): IAutoDestroyObject;
begin
Result := TAutoDestroyObject.Create(obj);
end;
FList := TObjectList.Create;
FListAutoDestroy := CreateAutoDestroyObject(FList);
Your usage example gets more complicated, too.
type
TSomeListWrap = record
List: TSomeList;
AutoDestroy: IAutoDestroyObject;
end;
function GetListWithItems: TSomeListWrap;
begin
Result.List := TSomeList.Create;
Result.AutoDestroy := CreateAutoDestroyObject(Result.List);
// add items to list
end;
var
Item: TSomeItem;
begin
for Item in GetListWithItems.List do
begin
// do something
end;
end;
Inspired by Barry Kelly's blog post here you could implement smart pointers for your purpose like this :
unit Unit80;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Generics.Collections;
type
TMyList =class( TList<Integer>)
public
destructor Destroy; override;
end;
TLifetimeWatcher = class(TInterfacedObject)
private
FWhenDone: TProc;
public
constructor Create(const AWhenDone: TProc);
destructor Destroy; override;
end;
TSmartPointer<T: class> = record
strict private
FValue: T;
FLifetime: IInterface;
public
constructor Create(const AValue: T); overload;
class operator Implicit(const AValue: T): TSmartPointer<T>;
property Value: T read FValue;
end;
TForm80 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
function getList : TSmartPointer<TMyList>;
{ Public declarations }
end;
var
Form80: TForm80;
implementation
{$R *.dfm}
{ TLifetimeWatcher }
constructor TLifetimeWatcher.Create(const AWhenDone: TProc);
begin
FWhenDone := AWhenDone;
end;
destructor TLifetimeWatcher.Destroy;
begin
if Assigned(FWhenDone) then
FWhenDone;
inherited;
end;
{ TSmartPointer<T> }
constructor TSmartPointer<T>.Create(const AValue: T);
begin
FValue := AValue;
FLifetime := TLifetimeWatcher.Create(procedure
begin
AValue.Free;
end);
end;
class operator TSmartPointer<T>.Implicit(const AValue: T): TSmartPointer<T>;
begin
Result := TSmartPointer<T>.Create(AValue);
end;
procedure TForm80.Button1Click(Sender: TObject);
var i: Integer;
begin
for I in getList.Value do
Memo1.Lines.Add(IntToStr(i));
end;
{ TMyList }
destructor TMyList.Destroy;
begin
ShowMessage('Kaputt');
inherited;
end;
function TForm80.getList: TSmartPointer<TMyList>;
var
x: TSmartPointer<TMyList>;
begin
x := TMyList.Create;
Result := x;
with Result.Value do
begin
Add(1);
Add(2);
Add(3);
end;
end;
end.
Look at getList and Button1click to see its usage.
To fully support what you're after the language would need to support 2 things:
Garbage collector. That's the only thing that gives you the freedom to USE something without bothering with freeing it. I'd welcome a change in Delphi that gave us even partial support for this.
The possibility to define local, initialized variables. Again, I'd really love to see something along those lines.
Meanwhile, the closest you can get is to use Interfaces in place of garbage collection (because interfaces are reference-counted, once they go out of scope they'll be released). As for initialized local variables, you could use a trick similar to what I'm describing here: Declaring block level variables for branches in delphi
And for the sake of fun, here's a Console application that demonstrates the use of "fake" local variables and Interfaces to obtain temporary lists that are readily initialized will be automatically freed:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils, Generics.Collections;
type
ITemporaryLocalVar<T:constructor> = interface
function GetL:T;
property L:T read GetL;
end;
TTemporaryLocalVar<T:constructor> = class(TInterfacedObject, ITemporaryLocalVar<T>)
public
FL: T;
constructor Create;
destructor Destroy;override;
function GetL:T;
end;
TTempUse = class
public
class function L<T:constructor>: ITemporaryLocalVar<T>;
end;
{ TTemporaryLocalVar<T> }
constructor TTemporaryLocalVar<T>.Create;
begin
FL := T.Create;
end;
destructor TTemporaryLocalVar<T>.Destroy;
begin
TObject(FL).Free;
inherited;
end;
function TTemporaryLocalVar<T>.GetL: T;
begin
Result := FL;
end;
{ TTempUse }
class function TTempUse.L<T>: ITemporaryLocalVar<T>;
begin
Result := TTemporaryLocalVar<T>.Create;
end;
var i:Integer;
begin
try
with TTempUse.L<TList<Integer>> do
begin
L.Add(1);
L.Add(2);
L.Add(3);
for i in L do
WriteLn(i);
end;
ReadLn;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The standard list classes, like TList, TObjectList, TInterfaceList, etc, do not implement automated lifecycles, so you have to free them manually when you are done using them. If you want a list class that is accessible via an interface, you have to implement that yourself, eg:
type
IListIntf = interface
...
end;
TListImpl = class(TInterfacedObject, IListIntf)
private
FList: TList;
...
public
constructor Create; override;
destructor Destroy; override;
...
end;
constructor TListImpl.Create;
begin
inherited;
FList := TList.Create;
end;
destructor TListImpl.Destroy;
begin
FList.Free;
inherited;
end;
function GetListWithItems: IListIntf;
begin
Result := TListImpl.Create;
// add items to list
end;
Another option is to implement a generic IEnumerable adapter (as one of the ways to satisfy the for .. in compiler requirement) and rely on reference counting of the interface. I don't know if the following works in Delphi 2009, it seems to work in Delphi XE:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils, Classes,
Generics.Collections;
type
// IEnumerator adapter for TEnumerator
TInterfacedEnumerator<T> = class(TInterfacedObject, IEnumerator<T>)
private
FEnumerator: TEnumerator<T>;
public
constructor Create(AEnumerator: TEnumerator<T>);
destructor Destroy; override;
function IEnumerator<T>.GetCurrent = GetCurrent2;
{ IEnumerator }
function GetCurrent: TObject;
function MoveNext: Boolean;
procedure Reset;
{ IEnumerator<T> }
function GetCurrent2: T;
end;
// procedure used to fill the list
TListInitProc<T> = reference to procedure(List: TList<T>);
// IEnumerable adapter for TEnumerable
TInterfacedEnumerable<T> = class(TInterfacedObject, IEnumerable<T>)
private
FEnumerable: TEnumerable<T>;
public
constructor Create(AEnumerable: TEnumerable<T>);
destructor Destroy; override;
class function Construct(InitProc: TListInitProc<T>): IEnumerable<T>;
function IEnumerable<T>.GetEnumerator = GetEnumerator2;
{ IEnumerable }
function GetEnumerator: IEnumerator; overload;
{ IEnumerable<T> }
function GetEnumerator2: IEnumerator<T>; overload;
end;
{ TInterfacedEnumerator<T> }
constructor TInterfacedEnumerator<T>.Create(AEnumerator: TEnumerator<T>);
begin
inherited Create;
FEnumerator := AEnumerator;
end;
destructor TInterfacedEnumerator<T>.Destroy;
begin
FEnumerator.Free;
inherited Destroy;
end;
function TInterfacedEnumerator<T>.GetCurrent: TObject;
begin
Result := TObject(GetCurrent2);
end;
function TInterfacedEnumerator<T>.GetCurrent2: T;
begin
Result := FEnumerator.Current;
end;
function TInterfacedEnumerator<T>.MoveNext: Boolean;
begin
Result := FEnumerator.MoveNext;
end;
procedure TInterfacedEnumerator<T>.Reset;
begin
// ?
end;
{ TInterfacedEnumerable<T> }
class function TInterfacedEnumerable<T>.Construct(InitProc: TListInitProc<T>): IEnumerable<T>;
var
List: TList<T>;
begin
List := TList<T>.Create;
try
if Assigned(InitProc) then
InitProc(List);
Result := Create(List);
except
List.Free;
raise;
end;
end;
constructor TInterfacedEnumerable<T>.Create(AEnumerable: TEnumerable<T>);
begin
inherited Create;
FEnumerable := AEnumerable;
end;
destructor TInterfacedEnumerable<T>.Destroy;
begin
FEnumerable.Free;
inherited Destroy;
end;
function TInterfacedEnumerable<T>.GetEnumerator: IEnumerator;
begin
Result := GetEnumerator2;
end;
function TInterfacedEnumerable<T>.GetEnumerator2: IEnumerator<T>;
begin
Result := TInterfacedEnumerator<T>.Create(FEnumerable.GetEnumerator);
end;
type
TSomeType = record
X, Y: Integer;
end;
function GetList(InitProc: TListInitProc<TSomeType>): IEnumerable<TSomeType>;
begin
Result := TInterfacedEnumerable<TSomeType>.Construct(InitProc);
end;
procedure MyInitList(List: TList<TSomeType>);
var
NewItem: TSomeType;
I: Integer;
begin
for I := 0 to 9 do
begin
NewItem.X := I;
NewItem.Y := 9 - I;
List.Add(NewItem);
end;
end;
procedure Main;
var
Item: TSomeType;
begin
for Item in GetList(MyInitList) do // you could also use an anonymous procedure here
Writeln(Format('X = %d, Y = %d', [Item.X, Item.Y]));
Readln;
end;
begin
try
ReportMemoryLeaksOnShutdown := True;
Main;
except
on E: Exception do
begin
ExitCode := 1;
Writeln(Format('[%s] %s', [E.ClassName, E.Message]));
end;
end;
end.
No, not 'out of the box' in Delphi.
I know that you don't need a library but you may be interessed by the principle of TDynArray.
In Jedi Code Library, exist the Guard function that already implements what
Gabr's code does.