Inheritance/polymorphism concept - delphi

I have two binary files that contain a similar type of data so I want to create a unified viewer (TViewer) for both files.
Some, methods are common for these two file types, some are not. So I created a base class
TShape, and the from it TCircle and TTriangle.
Pseudo code:
TShape = class(TObject)
function NoOfItems: integer; virtual; abstract;
end;
TCircle = class(TShape)
function NoOfItems: integer; override; <---- The real implementation
end;
TTriangle = class(TShape)
function NoOfItems: integer; override; <---- The real implementation
end;
TViewer = class(TStringGrid)
Container: TShape;
end;
And I use it like this:
Procedure Main;
begin
if FileType= Circle
then (Viewer.Container as TCircle).Load(FileName)
else (Viewer.Container as TTriangle).Load(FileName);
Caption:= Viewer.Container.NoOfItems; <---- it calls TShape which is abstract
end;
When I do this it works:
if Viewer.Container is TTriangle
then Caption:= (Viewer.Container as TTriangle).NoOfItems
else ...
but I want to do it directly like this:
Caption:= Viewer.Container.NoOfItems;
Obviously there is nothing wrong in using is except that I will have to use it in many many places (close to everywhere). There is a nicer way to achieve this unified viewer?
Update:
Actually, it may be also a performance problem. My file has a really big number of items (up to billions) so doing so many 'is/as' tests may actually have a real impact on speed.

You're doing it wrong.
You need to change your code so that the container is not created until you know what type it needs to be, and then create the proper type:
Procedure Main;
begin
if FileType= Circle then
Viewer.Container := TCircle.Create
else
Viewer.Container := TTriangle.Create;
Viewer.Container.Load(FileName);
Caption := IntToStr(Viewer.Container.NoOfItems); <---- it calls proper code
end;
Here's a working example of using inheritance and polymorphism for you:
program InheritancePolymorphismTest;
uses
System.SysUtils;
type
TAnimal=class
public
procedure Sit; virtual;
procedure Speak; virtual;
end;
TDog=class(TAnimal)
public
procedure Sit; override;
procedure Speak; override;
end;
TCat=class(TAnimal)
public
procedure Speak; override;
end;
TAnimalArray = array of TAnimal;
{ TCat }
procedure TCat.Speak;
begin
inherited;
WriteLn('Bah! No way cats speak when told.');
end;
{ TDog }
procedure TDog.Sit;
begin
inherited;
WriteLn('Sitting down.');
end;
procedure TDog.Speak;
begin
inherited;
Writeln('Woof! Woof!');
end;
procedure TAnimal.Sit;
begin
end;
procedure TAnimal.Speak;
begin
end;
var
Animals: TAnimalArray;
i: Integer;
Pet: TAnimal;
{ TAnimal }
const
NumAnimals = 5;
begin
SetLength(Animals, NumAnimals);
for i := 0 to High(Animals) do
begin
if Odd(i) then
Animals[i] := TDog.Create
else
Animals[i] := TCat.Create;
end;
for Pet in Animals do
begin
Pet.Speak;
Pet.Sit;
end;
Writeln('');
Readln;
end.

Real code and real output. Polymorphism still works!
So I think you have missed some important details while declaring and implementing your class hierarchy.
type
TShape = class(TObject)
function IAm: string; virtual; abstract;
end;
TCircle = class(TShape)
function IAm: string; override;
end;
TTriangle = class(TShape)
function IAm: string; override;
end;
{ TCircle }
function TCircle.IAm: string;
begin
Result := 'I am circle'
end;
{ TTriangle }
function TTriangle.IAm: string;
begin
Result := 'I am triangle'
end;
procedure TForm1.Button6Click(Sender: TObject);
var
Shape: TShape;
begin
Shape := TCircle.Create;
Memo1.Lines.Add(Shape.IAm);
Shape.Free;
Shape := TTriangle.Create;
Memo1.Lines.Add(Shape.IAm);
Shape.Free;
end;
output
I am circle
I am triangle

Related

Object serializing via RTTI doesn't work anymore

I have 2 years old project which I am rebooting back to life. I have debug window which shows different information, and one part of them is that it serializes various google protobuf objects and shows them.
Here is how typical protobuf class looks like:
// Generated by the protocol buffer compiler. DO NOT EDIT!
// Source: message.proto
unit Poker.Protobufs.Objects.PingParams;
interface
uses
System.SysUtils,
{$IFNDEF FPC} System.Generics.Collections {$ELSE} Contnrs {$ENDIF},
pbOutput, Poker.Protobufs.Objects.Base, Poker.Protobufs.Reader, Poker.Types;
type
TPB_PingParams = class(TProtobufBaseObject)
private
const
kUptimeFieldNumber = 1;
var
FUptime: UInt32;
FHasBits: UINT32;
procedure set_has_Uptime;
procedure clear_has_Uptime;
procedure SetUptime(const AValue: UInt32);
public
constructor Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE); overload;
destructor Destroy; override;
procedure LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer); override;
procedure MergeFrom(const AFrom: TPB_PingParams);
procedure Clear;
function IsInitialized: Boolean; override;
// required uint32 Uptime = 1;
function has_Uptime: Boolean;
procedure clear_Uptime;
property Uptime: UInt32 read FUptime write SetUptime;
end;
TPB_PingParamsList = class(TObjectList<TPB_PingParams>)
procedure Assign(const APB_PingParamsList: TList<TPB_PingParams>);
end;
implementation
uses
pbPublic;
constructor TPB_PingParams.Create(const AFrom: TPB_PingParams; const ALightweight: Boolean = FALSE);
begin
inherited Create(ALightweight);
MergeFrom(AFrom);
end;
destructor TPB_PingParams.Destroy;
begin
inherited;
end;
procedure TPB_PingParams.LoadFromProtobufReader(const AProtobufReader: TProtobufReader; const ASize: Integer);
var
tag, field_number, wire_type, endpos: Integer;
begin
endpos := AProtobufReader.getPos + ASize;
while (AProtobufReader.getPos < endpos) and
(AProtobufReader.GetNext(tag, wire_type, field_number)) do
case field_number of
kUptimeFieldNumber: begin
Assert(wire_type = WIRETYPE_VARINT);
FUptime := AProtobufReader.readUInt32;
set_has_Uptime;
end;
else
AProtobufReader.skipField(tag);
end;
end;
procedure TPB_PingParams.MergeFrom(const AFrom: TPB_PingParams);
begin
if AFrom.has_Uptime then
SetUptime(AFrom.Uptime);
end;
function TPB_PingParams.IsInitialized: Boolean;
begin
if (FHasBits and $1) <> $1 then
Exit(FALSE);
Exit(TRUE);
end;
procedure TPB_PingParams.clear_Uptime;
begin
FUptime := 0;
clear_has_Uptime;
end;
function TPB_PingParams.has_Uptime: Boolean;
begin
result := (FHasBits and 1) > 0;
end;
procedure TPB_PingParams.set_has_Uptime;
begin
FHasBits := FHasBits or 1;
end;
procedure TPB_PingParams.clear_has_Uptime;
begin
FHasBits := FHasBits and not 1;
end;
procedure TPB_PingParams.SetUptime(const AValue: UInt32);
begin
if not Lightweight then
Assert(not has_Uptime);
FUptime := AValue;
if not Lightweight then
ProtobufOutput.writeUInt32(kUptimeFieldNumber, AValue);
set_has_Uptime;
end;
procedure TPB_PingParams.Clear;
begin
if FHasBits = 0 then
Exit;
clear_Uptime;
end;
procedure TPB_PingParamsList.Assign(const APB_PingParamsList: TList<TPB_PingParams>);
var
pbobj: TPB_PingParams;
begin
Clear;
for pbobj in APB_PingParamsList do
Add(TPB_PingParams.Create(pbobj, TRUE));
end;
end.
And my serialization function:
function SerializeObject(const AObject: TObject): String;
var
t: TRttiType;
p: TRttiProperty;
properties: TArray<TRttiProperty>;
method: TRttiMethod;
begin
result := '';
if not Assigned(AObject) then
Exit;
t := TRttiContext.Create.GetType(AObject.ClassType);
properties := t.GetProperties;
for p in properties do
begin
method := t.GetMethod(Format('has_%s', [p.Name]));
if (Assigned(method)) and
(method.Invoke(AObject, []).AsBoolean) then
result := result + Format('%s: %s; ', [p.Name, ValueToStr(p, p.GetValue(AObject))]);
end;
end;
It is specifically designed to serialize fields that begin with has_ in protobuf objects. Now, I didn't change anything in the code over last 2 years, and this was working before. But now it doesn't. Line properties = t.GetProperties returns empty array for my protobuf classes.
My guess is that I had some globally defined compiler directive which allowed me to serialize public methods in the class. But I cannot figure out which one.
If I put {$M+} in front of my protobuf classes, and move methods to published, it works (kinda). But this worked before just like it is shown in the sources, without any {$M+} directives or similar. So I'm curious what I miss.
Compiler is same as before, XE2.

Where can I find TMonitor (Delphi 7) or how can I replace it with an alternative function?

I have a code (Singleton- Pattern) which works with Delphi RAD 10.1
type
TSharedData = class
private
FPOL: integer;
class var FUniqueInstance: TSharedData;
procedure SetFPol(const Value: integer);
constructor Create;
public
class function GetInstance: TSharedData;
property POL: integer read FPOL write SetFPol;
end;
var
Key: TObject;
implementation
{ TSharedData }
constructor TSharedData.Create;
begin
SetFPol(1);
end;
class function TSharedData.GetInstance: TSharedData;
begin
TMonitor.Enter(Key); // <-- error here
try
if FUniqueInstance = nil then
begin
FUniqueInstance := TSharedData.Create;
end;
finally
TMonitor.Exit(Key);
end;
Result := FUniqueInstance;
end;
procedure TSharedData.SetFPol(const Value: integer);
begin
FPOL := Value;
end;
initialization
Key:= TObject.Create;
finalization
Key.Free;
I need now the same code in Delphi 7. But the compiler said, "TMonitor isn't known".
Where can I find TMonitor or how can I replace it with an alternative function?
I thank you in advance for any information.
You can use TCriticalSection from SyncObjs unit.
The approach changes just a little bit. The critical section should be used as an object. So if you want to protect an area of you object on can do something like:
type
TSafeCounter = class(TObject)
private
FValue: Integer;
FCriticalSection: TCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure SafeInc;
procedure SafeDec;
function CurValue: Integer;
end;
implementation
{ TSafeCounter }
constructor TSafeCounter.Create;
begin
FCriticalSection := TCriticalSection.Create;
end;
function TSafeCounter.CurValue: Integer;
begin
FCriticalSection.Acquire;
try
Result := FValue;
finally
FCriticalSection.Release;
end;
end;
procedure TSafeCounter.SafeDec;
begin
FCriticalSection.Acquire;
try
Dec(FValue);
finally
FCriticalSection.Release;
end;
end;
destructor TSafeCounter.Destroy;
begin
FCriticalSection.Free;
inherited;
end;
procedure TSafeCounter.SafeInc;
begin
FCriticalSection.Acquire;
try
Inc(FValue);
finally
FCriticalSection.Release;
end;
end;
If you are facing very extreme scenario (performance), you can work another kinds of implementations of critical sections, but them will also increase the complexity of working with it like the read/write critical section.

Appropriate object creation - finding universal solution

There are 3 classes (there may be much more), which have the same procedure (procedure Populate). They are nearly identical and differs only by object creation. All I want is to write a universal procedure in the base class, which will replace this notorious repeating of code forever. I am not really sure, if I can express exactly what I am up to, but look at the code below and see.
TGrandFather = class(TObject)
end;
TFather = class(TGrandFather)
end;
TSon = class(TFather)
end;
TGrandson.... and so on...
TGrandFathers = class (TList)
public
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure Populate(Amount:Integer);
end;
TSons = class (TFathers)
public
procedure Populate(Amount:Integer);
end;
TGrandsons....
...
procedure TGrandFathers.Populate(Amount:Integer);
var i:integer;
xGrandFather:TGrandFather;
begin
for i := 0 to Amount do
begin
xGrandFather:=TGrandFather.Create;
Add(xGrandFather);
end;
end;
procedure TFathers.Populate(Amount:Integer);
var i:integer;
xFather:TFather;
begin
for i := 0 to Amount do
begin
xFather:=TFather.Create; //this is the point, which makes trouble
Add(xFather);
end;
end;
procedure TSons.Populate(Amount:Integer);
var i:integer;
xSon:TSon;
begin
for i := 0 to Amount do
begin
xSon:=TSon.Create; //this is the point, which makes trouble
Add(xSon);
end;
end;
procedure Grandsons...
Thanx...
To answer your question, you could use a metaclass through "class of" if you want to go the route you are going. This block of code demonstrates how you would accomplish that. The hierarchy needs to be cleaned up but you should get the gist of what is going on through this code.
A metaclass is a class whose instances are classes. This allows you to build a more generic framework because you can then use your metaclass to create the classes that you need.
type
TGrandFather = class(TObject)
end;
TStrangeHeirarchyClass = class of TGrandFather;
TFather = class(TGrandFather)
end;
TSon = class(TFather)
end;
TGrandFathers = class(TList)
protected
procedure PopulateInternal(aAmount:Integer; aContainedClass:
TStrangeHeirarchyClass);
public
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure Populate(Amount:Integer);
end;
TSons = class (TFathers)
public
procedure Populate(Amount:Integer);
end;
implementation
procedure TGrandFathers.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TGrandFather);
end;
procedure TGrandFathers.PopulateInternal(aAmount:Integer; aContainedClass:
TStrangeHeirarchyClass);
var
i:integer;
xFamilyMember:TGrandFather;
begin
for i := 0 to aAmount do
begin
xFamilyMember := aContainedClass.Create;
Add(xFamilyMember);
end;
end;
procedure TFathers.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TFather);
end;
procedure TSons.Populate(Amount:Integer);
begin
PopulateInternal(Amount, TSon);
end;
The way it works is that the metaclass TStrangeHeirarchyClass, which you can use just like a regular data type, stores the underlying class that you would like to work with. You can pass the type in as a parameter (like I did in the code example above) or store it in the class as a property or field like this:
TGrandFathers = class(TList)
private
FContainedClass: TStrangeHeirarchyClass;
public
procedure Populate(Amount:Integer);
property ContainedClass: TStrangeHeirarchyClass read
FContainedClass write FContainedClass;
end;
Once you have set this property you would then be able to use it to create instances of the class type that it was set to. So, setting the ContainedClass as a TFather would result in calls to ContainedClass.Create creating instances of TFather.
As David indicated in the comments, you will run into problems if you use a metaclass and override the default constructor. Your code in the constructor will never run. You either need to wither use virtual constructors or override the existing AfterConstruction method which is a virtual method that is called by the constructor. Something like this would be an example if you were using AfterConstruction:
TGrandFathers = class(TList)
protected
FContainedClass: TStrangeHeirarchyClass;
public
procedure AfterConstruction; override;
procedure Populate(Amount:Integer);
end;
TFathers = class (TGrandFathers)
public
procedure AfterConstruction; override;
end;
TSons = class (TFathers)
public
procedure AfterConstruction; override;
end;
implementation
procedure TGrandFathers.AfterConstruction;
begin
inherited;
FContainedClass := TGrandFather;
// Other construction code
end;
procedure TGrandFathers.Populate(aAmount:Integer);
var
i:integer;
xFamilyMember:TGrandFather;
begin
for i := 0 to aAmount do
begin
xFamilyMember := FContainedClass.Create;
Add(xFamilyMember);
end;
end;
procedure TFathers.AfterConstruction;
begin
inherited;
FContainedClass := TFather;
// Other construction code
end;
procedure TSons.AfterConstruction;
begin
inherited;
FContainedClass := TSon;
// Other construction code
end;
Your hierarchy looks very strange though. I think something like this would be more appropriate:
type
TRelationType = (ptSon, ptFather, ptGrandfather);
TPerson = class;
TRelation = class(TObject)
strict private
FRelationship: TRelationType;
FRelation: TPerson;
public
property Relation: TPerson read FRelation write FRelation;
property Relationship: TRelationType read FRelationship write FRelationship;
end;
TRelationList = class(TList)
//...
end;
TPerson = class(TObject)
strict private
FPersonName: string;
FRelations: TRelationList;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
property PersonName: string read FPersonName write FPersonName;
property Relations: TRelationList read FRelations;
end;
implementation
procedure TPerson.AfterConstruction;
begin
inherited;
FRelations := TRelationList.Create;
end;
procedure TPerson.BeforeDestruction;
begin
FRelations.Free;
inherited;
end;
This seems to work:
//MMWIN:CLASSCOPY
unit _MM_Copy_Buffer_;
interface
implementation
type
TBaseSelfCreating = class(TObject)
procedure Populate(Amount: Integer);
procedure Add(Obj: TObject);
end;
{TBaseSelfCreating}
procedure TBaseSelfCreating.Add(Obj: TObject);
begin
Assert(Obj is TBaseSelfCreating);
Assert(Obj <> Self);
Obj.Free;
end;
procedure TBaseSelfCreating.Populate(Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do Add(Self.ClassType.Create);
end;
end.
Simply use Self.ClassType.Create:
program Project13;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
TFoo1 = class
procedure Boo;
end;
TFoo2 = class(TFoo1)
end;
{ TFoo1 }
procedure TFoo1.Boo;
var
x: TFoo1;
begin
x := Self.ClassType.Create as TFoo1;
write(Cardinal(Self):16, Cardinal(x):16);
Writeln(x.ClassName:16);
end;
begin
try
TFoo1.Create.Boo;
TFoo2.Create.Boo;
Readln;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
If you do not want to use Generics or you are using a version of Delphi without Generics, then this is a way. Yes, I know I can use forward declaration to remove one class, but this is clearer to follow.
Interface
type
TBaseAncestor = class
end;
TBaseClass = class of TBaseAncestor;
TGrandFathers = class (TBaseAncestor)
FClassType : TBaseClass;
constructor Create (AOwner : TControl); reintroduce; virtual;
procedure Populate;
procedure Add (X : TBaseAncestor);
end;
TFathers = class (TGrandFathers)
constructor Create (AOwner : TControl); override;
end;
Implementation
{ TGrandFathers }
constructor TGrandFathers.Create(AOwner: TControl);
begin
inherited Create;
FClassType := TGrandFathers;
end;
procedure TGrandFathers.Add (X : TBaseAncestor);
begin
end;
procedure TGrandFathers.Populate;
const
Amount = 5;
var
I : integer;
x : TBaseAncestor;
begin
for I := 0 to Amount do
begin
x := FClassType.Create;
Add (x);
end;
end;
{ TFathers }
constructor TFathers.Create(AOwner: TControl);
begin
inherited;
FClassType := TFathers;
end;
Each descendant stores its class into the class variable. And Populate uses this for Creation. I have been using this before Generics came along.

Keep values from the beforepost event to the afterpost event

I am writing this question for Delphi 2007, but I'm pretty sure that this is a common problem in all kind of languages.
So, I have a project where I need to keep informations about the old and new value of certain fields (which are given in the BeforePost event of the dataset I'm working with) and use them in the AfterPost event.
For now, I have been using global variables, but there is already so many of them in the project that this is becoming a real issue when it comes to managing documentation and/or comments.
Basically, I am asking if there is a better way (in Delphi 2007 or in general) to keep the informations from the BeforePost event of a Dataset and get them back in the AfterPost event.
first create a new Custom Data Source
TDataRecord = array of record
FieldName: string;
FieldValue: Variant;
end;
TMyDataSource = class(TDataSource)
private
LastValues: TDataRecord;
procedure MyDataSourceBeforePost(DataSet: TDataSet);
procedure SetDataSet(const Value: TDataSet);
function GetDataSet: TDataSet;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLastValue(FieldName: string): Variant;
property MyDataSet: TDataSet read GetDataSet write SetDataSet;
end;
{ TMyDataSource }
constructor TMyDataSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TMyDataSource.Destroy;
begin
SetLength(LastValues, 0);
inherited Destroy;
end;
function TMyDataSource.GetDataSet: TDataSet;
begin
Result := DataSet;
end;
procedure TMyDataSource.SetDataSet(const Value: TDataSet);
begin
DataSet := Value;
DataSet.BeforePost := MyDataSourceBeforePost;
end;
procedure TMyDataSource.MyDataSourceBeforePost(DataSet: TDataSet);
var
i: integer;
begin
SetLength(LastValues, DataSet.FieldCount);
for i:=0 to DataSet.FieldCount-1 do
begin
LastValues[i].FieldName := DataSet.Fields.Fields[i].FieldName;
LastValues[i].FieldValue := DataSet.Fields.Fields[i].OldValue;
end;
end;
function TMyDataSource.GetLastValue(FieldName: string): Variant;
var
i: integer;
begin
Result := Null;
for i:=0 to Length(LastValues)-1 do
if SameText(FieldName, LastValues[i].FieldName) then
begin
Result := LastValues[i].FieldValue;
break;
end;
end;
and after override application Data Source
TForm1 = class(TForm)
private
MyDataSource: TMyDataSource;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ADOQuery1.Active := true;
MyDataSource := TMyDataSource.Create(Self);
MyDataSource.MyDataSet := ADOQuery1;
DBGrid1.DataSource := MyDataSource;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyDataSource.Free;
end;
procedure TForm1.ADOQuery1AfterPost(DataSet: TDataSet);
var
AValue: Variant;
begin
AValue := MyDataSource.GetLastValue('cname');
if not VarIsNull(AValue) then;
end;

Which lists could serve as temporary lists?

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.

Resources