I need a list of polymorphic objects (different object classes, but with a common base class) that I can 'persist' as part of a form file.
TList isn't persistent, and TCollection isn't polymorphic.
I can probably roll my own but prefer not to reinvent the wheel. Ideas?
None of the standard library classes meet you needs. You need to roll your own, or find a third party library.
For using default streaming framework you have to create wrapper collection item that can hold and create object instances of different classes.
unit PolyU;
interface
uses
System.SysUtils,
System.Classes;
type
TWrapperItem = class(TCollectionItem)
protected
FObjClassName: string;
FObjClass: TPersistentClass;
FObj: TPersistent;
procedure SetObjClass(Value: TPersistentClass);
procedure SetObjClassName(Value: string);
procedure SetObj(Value: TPersistent);
function CreateObject(OClass: TPersistentClass): Boolean; dynamic;
public
property ObjClass: TPersistentClass read FObjClass write SetObjClass;
published
// ObjClassName must be published before Obj to trigger CreateObject
property ObjClassName: string read FObjClassName write SetObjClassName;
property Obj: TPersistent read FObj write SetObj;
end;
implementation
procedure TWrapperItem.SetObjClass(Value: TPersistentClass);
begin
if Value <> FObjClass then
begin
FObj := nil;
FObjClass := Value;
if Value = nil then FObjClassName := ''
else FObjClassName := Value.ClassName;
CreateObject(FObjClass);
end;
end;
procedure TWrapperItem.SetObjClassName(Value: string);
begin
if Value <> FObjClassName then
begin
FObj := nil;
FObjClassName := Value;
if Value = '' then FObjClass := nil
else FObjClass := FindClass(Value);
CreateObject(FObjClass);
end;
end;
procedure TWrapperItem.SetObj(Value: TPersistent);
begin
FObj := Value;
if Assigned(Value) then
begin
FObjClassName := Value.ClassName;
FObjClass := TPersistentClass(Value.ClassType);
end
else
begin
FObjClassName := '';
FObjClass := nil;
end;
end;
function TWrapperItem.CreateObject(OClass: TPersistentClass): Boolean;
begin
Result := false;
if OClass = nil then exit;
try
FreeAndNil(FObj);
if OClass.InheritsFrom(TCollectionItem) then FObj := TCollectionItem(TCollectionItemClass(OClass).Create(nil))
else
if OClass.InheritsFrom(TComponent) then FObj := TComponentClass(OClass).Create(nil)
else
if OClass.InheritsFrom(TPersistent) then FObj := TPersistentClass(OClass).Create;
Result := true;
except
end;
end;
end.
Classes that are going to be wrapped by TWrapperItem have to be registered with Delphi streaming system via RegisterClass or RegisterClasses methods.
Following test component contains base collection that can be edited and streamed through IDE. For more control it is possible that you may want to write custom IDE editors, but this is base to start from.
unit Unit1;
interface
uses
System.Classes,
PolyU;
type
TFoo = class(TPersistent)
protected
FFoo: string;
published
property Foo: string read FFoo write FFoo;
end;
TBar = class(TPersistent)
protected
FBar: integer;
published
property Bar: integer read FBar write FBar;
end;
TTestComponent = class(TComponent)
protected
FList: TOwnedCollection;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property List: TOwnedCollection read FList write FList;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Test', [TTestComponent]);
end;
constructor TTestComponent.Create(AOwner: TComponent);
begin
inherited;
FList := TOwnedCollection.Create(Self, TWrapperItem);
end;
destructor TTestComponent.Destroy;
begin
Flist.Free;
inherited;
end;
initialization
RegisterClasses([TFoo, TBar]);
finalization
UnRegisterClasses([TFoo, TBar]);
end.
This is how streamed TTestComponent (as part of Form) can look like:
object TestComponent1: TTestComponent
List = <
item
ObjClassName = 'TFoo'
Obj.Foo = 'abc'
end
item
ObjClassName = 'TBar'
Obj.Bar = 5
end>
Left = 288
Top = 16
end
I am not sure why a TCollection can not hold TCats and TDogs ?
TAnimal = class(TCollectionItem)
end;
TCat = class(TAnimal)
end;
TDog = class(TAnimal)
end;
FCollection : TCollection;
FCollection := TCollection.Create(TAnimal);
cat : TCat
cat := TCat.Create(FCollection);
dog : TDog
dog := TDag.Create(FCollection);
var
i : integer;
begin
for I := 0 to FCollection.Count - 1 do
TAnimal(FCollection.Items[i]).DoSomething;
end;
FCollection will now hold 2 items, a cat and a dog
Or I am missing the point here ?
Related
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.
So, I am getting Access Violation error when try to Mock 2-nd composite interface, below examples of code with using Delphi-Mocks and Spring4D frameworks
unit u_DB;
type
TDBObject = class
public
property ID: TGUID;
end;
TDBCRM = class(TDBObject)
public
property SOME_FIELD: TSomeType;
end;
unit i_dmServer;
type
{$M+}
IdmServer = interface
['{A4475441-9651-4956-8310-16FB710EAE5E}']
function GetServiceConnection: TServiceConnection;
function GetCurrentUser(): TUser;
end;
unit d_ServerWrapper;
type
TdmServerWrapper = class(TInterfacedObject, IdmServer)
private
function GetServiceConnection: TServiceConnection;
function GetCurrentUser(): TUser;
protected
FdmServer: TdmServer;
end;
implementation
constructor TdmServerWrapper.Create();
begin
inherited Create();
FdmServer := TdmServer.Create(nil);
end;
end.
unit i_BaseDAL;
type
{$M+}
IBaseDAL<T: TDBObject, constructor> = interface
['{56D48844-BD7F-4FF8-A4AE-30DA1A82AD67}']
procedure RefreshData(); ....
end;
unit u_BaseDAL;
type
TBaseDAL<T: TDBObject, constructor> = class(TInterfacedObject, IBaseDAL<TDBObject>)
protected
FdmServer: IdmServer;
public
procedure RefreshData();
end;
implementation
procedure TBaseDAL<T>.Create;
begin
FdmServer := GlobalContainer.Resolve<IdmServer>;
end;
end.
unit ChildFrame;
interface
type
TChildFrame = class(TFrame)
private
fDM: IBaseDAL<TDBObject>;
function GetDM: IBaseDAL<TDBObject>;
procedure SetDM(const Value: IBaseDAL<TDBObject>);
public
constructor Create(AOwner: TComponent); override;
property DM: IBaseDAL<TDBObject> read GetDM write SetDM;
end;
implementation
constructor TChildFrame.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DM := nil;
end;
function TChildFrame.GetDM: IBaseDAL<TDBObject>;
begin
if not Assigned(fDM) then
fDM := GlobalContainer.Resolve<IBaseDAL<TDBObject>>;
Result := fDM;
end;
procedure TfrmCustomChildFrame.SetDM(const Value: IBaseDAL<TDBObject>);
begin
if Assigned(fDM) then
fDM := nil;
fDM := Value;
end;
end.
TCRMFrame = class(TChildFrame)
....
end;
procedure TCRMFrame.Create
begin
DM := GlobalContainer.Resolve('i_BaseDAL.IBaseDAL<u_DB.TDBObject>#TBaseDAL<u_DB.TDBCRM>').AsInterface as IBaseDAL<TDBObject>;
// DM := GlobalContainer.Resolve(IBaseDAL<TomDBObject>); {Not compiled et all: "E2250 There is no overloaded version of 'Resolve' that can be called with these arguments"}
end;
REGISTERING TYPES
unit RegisteringTypes.pas
procedure RegTypes;
implementation
procedure RegTypes;
begin
GlobalContainer.RegisterType<TdmServerWrapper>;
GlobalContainer.RegisterType<TBaseDAL<TDBObject>, IBaseDAL<TDBObject>>;
GlobalContainer.RegisterType<TBaseDAL<TDBCRM>, IBaseDAL<TDBCRM>>;
GlobalContainer.Build;
end;
initialization
RegTypes
end.
DUNIT TEST
type
TestTCRM = class(TTestCase)
private
FFrame: TCRMFrame;
FBaseDALMock: TMock<TBaseDAL<TDBObject>>;
procedure Init;
protected
procedure SetUp; override;
published
end;
implementation
procedure TestTCRM.Init;
begin
inherited;
GlobalContainer.RegisterType<IdmServer>.DelegateTo(
function: IdmServer
begin
Result := TMock<IdmServer>.Create;
end
);
GlobalContainer.RegisterType<IBaseDAL<TDBCRM>>.DelegateTo(
function: IBaseDAL<TDBCRM>
begin
Result := TMock<IBaseDAL<TDBCRM>>.Create;
end
);
GlobalContainer.RegisterType<IBaseDAL<TDBObject>>.DelegateTo(
function: IBaseDAL<TDBObject>
begin
Result := TMock<IBaseDAL<TDBObject>>.Create;
end
);
GlobalContainer.Build;
end;
procedure TestTfrCRMAccountClasses.SetUp;
begin
inherited;
Init;
FFrame := TCRMFrame.Create(nil); // and I got ACCESS VIOLATION HERE
end;
Full sources of test project here - https://drive.google.com/file/d/0B6KvjsGVp4ONeXBNenlMc2J0R2M.
Colleagues, please advise me where I am wrong. Thank you in advance!
The AV is raised from Delphi.Mocks.
Here is a minimal test case to reproduce it:
procedure DelphiMocksTest;
var
func: TFunc<IdmServer>;
dm: IdmServer;
i: IInitializable;
begin
func :=
function: IdmServer
begin
Result := TMock<IdmServer>.Create;
Supports(dm, IInitializable, i); // works
end; // TMock record goes out of scope and something happens
dm := func();
Supports(dm, IInitializable, i); // fails
end;
You need to have a reference to the TMock somewhere, because the mocks are records which will get cleaned up when they go out of scope.
This should work :
procedure DelphiMocksTest;
var
func: TFunc<IdmServer>;
dm: IdmServer;
i: IInitializable;
mock : TMock<IdmServer>;
begin
func := function: IdmServer
begin
mock := TMock<IdmServer>.Create;
Supports(dm, IInitializable, i); // works
result := mock;
end;
dm := func();
Supports(dm, IInitializable, i); // fails
end;
Please consider such scenerio:
I have component called TMenuItemSelector which has two published properties: PopupMenu - allows to pick an instance of TPopupMenu from the form and MenuItem which allows to pick any instance of TMenuItem from the form.
I would like to modify property editor for MenuItem property in a way that when PopupMenu is assigned then only menu items from this PopupMenu are visible in a drop down list.
I know that I need to write my own descendant of TComponentProperty and override GetValues method. The problem is that I do not know how to access the form on which TMenuItemSelector is lying.
Original TComponentProperty is using this method to iterate all available instances:
procedure TComponentProperty.GetValues(Proc: TGetStrProc);
begin
Designer.GetComponentNames(GetTypeData(GetPropType), Proc);
end;
However, Designer seems to be precompiled so I have no idea how GetComponentNames works.
This is what I have so far, I guess only thing which I am missing is the implementation of GetValues:
unit uMenuItemSelector;
interface
uses
Classes, Menus, DesignIntf, DesignEditors;
type
TMenuItemSelector = class(TComponent)
private
FPopupMenu: TPopUpMenu;
FMenuItem: TMenuItem;
procedure SetPopupMenu(const Value: TPopUpMenu);
procedure SetMenuItem(const Value: TMenuItem);
published
property PopupMenu: TPopUpMenu read FPopupMenu write SetPopupMenu;
property MenuItem: TMenuItem read FMenuItem write SetMenuItem;
end;
type
TMenuItemProp = class(TComponentProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TMenuItem), TMenuItemSelector, 'MenuItem', TMenuItemProp);
RegisterComponents('Test', [TMenuItemSelector]);
end;
{ TMenuItemSelector }
procedure TMenuItemSelector.SetMenuItem(const Value: TMenuItem);
begin
FMenuItem := Value;
end;
procedure TMenuItemSelector.SetPopupMenu(const Value: TPopUpMenu);
begin
FPopupMenu := Value;
end;
{ TMenuItemProperty }
function TMenuItemProp.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paValueList, paSortList];
end;
procedure TMenuItemProp.GetValues(Proc: TGetStrProc);
begin
//How to filter MenuItems from the form in a way that only
//MenuItems which belong to TMenuItemSelector.PopupMenu are displayed? \
//And how to get to that form?
//inherited;
end;
end.
Anyone could help?
Thanks.
When TMenuItemProp.GetValues() is called, you need to look at the TMenuItemSelector object whose MenuItem property is currently being edited, see if that object has a PopupMenu assigned, and if so then loop through its items as neded, eg:
procedure TMenuItemProp.GetValues(Proc: TGetStrProc);
var
Selector: TMenuItemSelector;
I: Integer;
begin
Selector := GetComponent(0) as TMenuItemSelector;
if Selector.PopupMenu <> nil then
begin
with Selector.PopupMenu.Items do
begin
for I := 0 to Count-1 do
Proc(Designer.GetComponentName(Items[I]));
end;
end else
inherited GetValues(Proc);
end;
BTW, you need to implement TMenuItemSelector and TMenuItemProp in separate packages. With the exception of the RegisterComponents() function, (which is implemented in a runtime package), design-time code is not allowed to be compiled into run-time executables. It is against the EULA, and Embarcadero's design-time pacakges are not allowed to be distributed. You need to implement TMenuItemSelector in a runtime-only package, and then implement TMenuItemProp and Register() in a designtime-only package that Requires the runtime-only package and uses the unit that TMenuItemSelector is declared in, eg:
unit uMenuItemSelector;
interface
uses
Classes, Menus;
type
TMenuItemSelector = class(TComponent)
private
FPopupMenu: TPopUpMenu;
FMenuItem: TMenuItem;
procedure SetPopupMenu(const Value: TPopUpMenu);
procedure SetMenuItem(const Value: TMenuItem);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
published
property PopupMenu: TPopUpMenu read FPopupMenu write SetPopupMenu;
property MenuItem: TMenuItem read FMenuItem write SetMenuItem;
end;
implementation
{ TMenuItemSelector }
procedure TMenuItemSelector.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if Operation = opRemove then
begin
if AComponent = FPopupMenu then
begin
FPopupMenu := nil;
FMenuItem := nil;
end
else if AComponent = FMenuItem then
begin
FMenuItem := nil;
end;
end;
end;
procedure TMenuItemSelector.SetMenuItem(const Value: TMenuItem);
begin
if FMenuItem <> Value then
begin
if FMenuItem <> nil then FMenuItem.RemoveFreeNotification(Self);
FMenuItem := Value;
if FMenuItem <> nil then FMenuItem.FreeNotification(Self);
end;
end;
procedure TMenuItemSelector.SetPopupMenu(const Value: TPopUpMenu);
begin
if FPopupMenu <> Value then
begin
if FPopupMenu <> nil then FPopupMenu.RemoveFreeNotification(Self);
FPopupMenu := Value;
if FPopupMenu <> nil then FPopupMenu.FreeNotification(Self);
SetMenuItem(nil);
end;
end;
end.
.
unit uMenuItemSelectorEditor;
interface
uses
Classes, DesignIntf, DesignEditors;
type
TMenuItemSelectorMenuItemProp = class(TComponentProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure GetValues(Proc: TGetStrProc); override;
end;
procedure Register;
implementation
uses
Menus, uMenuItemSelector;
procedure Register;
begin
RegisterComponents('Test', [TMenuItemSelector]);
RegisterPropertyEditor(TypeInfo(TMenuItem), TMenuItemSelector, 'MenuItem', TMenuItemSelectorMenuItemProp);
end;
{ TMenuItemSelectorMenuItemProp }
function TMenuItemSelectorMenuItemProp.GetAttributes: TPropertyAttributes;
begin
Result := inherited GetAttributes + [paValueList, paSortList] - [paMultiSelect];
end;
procedure TMenuItemSelectorMenuItemProp.GetValues(Proc: TGetStrProc);
var
Selector: TMenuItemSelector;
I: Integer;
begin
Selector := GetComponent(0) as TMenuItemSelector;
if Selector.PopupMenu <> nil then
begin
with Selector.PopupMenu.Items do
begin
for I := 0 to Count-1 do
Proc(Designer.GetComponentName(Items[I]));
end;
end else
inherited GetValues(Proc);
end;
end.
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.
I use a TcxExtLookupComboBox from Devexpress and try to implement a custom datasource. I have set the customdatasource like this:
procedure TMainForm.FormCreate(Sender: TObject);
begin
fDataSource := TMyDataSource.Create;
cbotestSearch.Properties.View.DataController.CustomDataSource := fDataSource;
end;
TMyDataSource is defined here:
unit Datasource;
interface
uses
Classes,
IBQuery,
SysUtils,
cxCustomData;
type
TSearchItem = class
private
BoldID: String;
Display: String
end;
TMyDataSource = class(TcxCustomDataSource)
private
fSearchList: TList;
protected
function GetRecordCount: Integer; override;
function GetValue(ARecordHandle: TcxDataRecordHandle; AItemHandle: TcxDataItemHandle): Variant; override;
public
constructor Create;
destructor Destroy; override;
procedure GetData;
end;
implementation
constructor TMyDataSource.Create;
begin
inherited Create;
fSearchList := TList.Create;
end;
destructor TMyDataSource.Destroy;
begin
FreeAndNil(fSearchList);
inherited;
end;
procedure TMyDataSource.GetData;
var
vItem: TSearchItem;
begin
fSearchList.Clear;
vItem := TSearchItem.Create;
vItem.BoldID := '1000';
vItem.Display := 'test';
fSearchList.Add(vItem);
vItem := TSearchItem.Create;
vItem.BoldID := '1100';
vItem.Display := 'test2';
fSearchList.Add(vItem);
DataChanged; // Don't do anything as provider is nil
end;
function TMyDataSource.GetRecordCount: Integer;
begin
// Is never entered
Result := fSearchList.Count;
end;
function TMyDataSource.GetValue(ARecordHandle: TcxDataRecordHandle;
AItemHandle: TcxDataItemHandle): Variant;
begin
// Is never entered
Result := 'Test';
end;
end.
The problem is that TMyDataSource.GetValue is never called. Any hint how to fix ?
Update 1: I have another hint here. If I single step in the DataChanged method that should cause GetValue to be called is looks like this:
procedure TcxCustomDataSource.DataChanged;
begin
if Provider = nil then Exit;
// Code using Provider
end;
and Provider is nil in this case. But I have assigned the Datasource in Forms oncreate as you see.
cxExtLookupComboBox can only work with DB~views. Such views cannot accept instances of the TcxCustomDataSource object as a DataSource. So, your code will not work :-(. There is a suggestion to implement this feature in the future and it is registered at:
http://www.devexpress.com/Support/Center/ViewIssue.aspx?issueid=AS10025