Array of a custom class as a property - class

I am trying to use an array of a custom class as a property for my component, but the problem is that the values are not been saved to the component, that means that if I set the values, save everything and open again the project, the values for the component disappears... My code looks like the following:
unit Unit1;
interface
uses Windows, ExtCtrls,Classes,Controls;
type
TMyClass=class(TPersistent)
private
FName: string;
FValue: double;
public
property Name: string read FName write FName;
property Value: double read FValue write FValue;
end;
TMyComponent= class(TCustomPanel)
private
FMyArray: array[0..200] of TMyClass;
function GetmyArray(Index: Integer): TMyClass;
procedure SetMyArray(index: Integer; Value: TMyClass);
public
property myArray[index: Integer]: TMyClass read GetMyArray write SetMyArray;
end;
implementation
function TMyComponent.GetmyArray(Index: Integer): TMyClass;
begin
result:= FmyArray[Index];
end;
procedure TMyComponent.SetMyArray(index: Integer; Value: TMyClass);
begin
FMyArray[index].FName:= Value.FName;
FMyArray[index].FValue:= Value.FValue;
end;
end.
I know that that only published properties can be streamed, but the problem is that my property is an array and it can not be published...
A suggestion that I had was to use DefineProperties() to provide a custom streaming but I don't see how to do this with an array.
Other possibility that I thought was to modify TMyClass to a kind of class that TMyComponent could be the parent of it, like it is done in TChart, which you can add different classes of series to it. But I don't know What class this should be
TMyClass=class(T???????????)
With that I could take out the property MyArray and create TMyClass and add to TMyComponent as the following:
MyArray1.parent:= MyComponent1;
MyArray2.parent:= MyComponent2;
...
. Which one is the better option? Or is there any other better idea?

The simpliest (and preferred) solution is to change TMyClass to derive from TCollectionItem and change TMyComponent.FMyArray to TOwnedCollection. Then the DFM will stream the items automatically for you, and you gain native design-time support for creating and manipulating TMyClass objects and their properties.
Try this:
unit Unit1;
interface
uses
Windows, ExtCtrls, Classes, Controls;
type
TMyClass = class(TCollectionItem)
private
FName: string;
FValue: double;
procedure SetName(const AValue: string);
procedure SetValue(AValue: double);
public
procedure Assign(ASource: TPersistent); override;
published
property Name: string read FName write SetName;
property Value: double read FValue write SetValue;
end;
TMyArray = class(TOwnedCollection)
private
function GetItem(Index: Integer): TMyClass;
procedure SetItem(Index: Integer; const Value: TMyClass);
public
constructor Create(AOwner: TPersistent);
function Add: TMyClass; reintroduce;
function Insert(Index: Integer): TMyClass; reintroduce;
property Items[Index: Integer]: TMyClass read GetItem write SetItem; default;
end;
TMyComponent = class(TCustomPanel)
private
FMyArray: TMyArray;
procedure SetMyArray(Value: TMyArray);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property myArray: TMyArray read FMyArray write SetMyArray;
end;
implementation
procedure TMyClass.Assign(ASource: TPersistent);
begin
if ASource is TMyClass then
begin
with TMyClass(ASource) do
begin
Self.FName := Name;
Self.FValue := Value;
end;
Changed(False);
end else
inherited;
end;
procedure TMyClass.SetName(const AValue: string);
begin
if FName <> AValue then
begin
FName := AValue;
Changed(False);
end;
end;
procedure TMyClass.SetValue(AValue: double);
begin
if FValue <> AValue then
begin
FValue := AValue;
Changed(False);
end;
end;
constructor TMyArray.Create(AOwner: TPersistent);
begin
inherited Create(AOwner, TMyClass);
end;
function TMyArray.GetItem(Index: Integer): TMyClass;
begin
Result := TMyClass(inherited GetItem(Index));
end;
procedure TMyArray.SetItem(Index: Integer; const Value: TMyClass);
begin
inherited SetItem(Index, Value);
end;
function TMyArray.Add: TMyClass;
begin
Result := TMyClass(inherited Add);
end;
function TMyArray.Insert(Index: Integer): TMyClass;
begin
Result := TMyClass(inherited Insert(Index));
end;
constructor TMyComponent.Create(AOwner: TComponent);
begin
inherited;
FMyArray := TMyArray.Create(Self);
end;
destructor TMyComponent.Destroy;
begin
FMyArray.Free;
inherited;
end;
procedure TMyComponent.SetMyArray(Value: TMyArray);
begin
FMyArray.Assign(Value);
end;
end.

I'd vote for DefineProperties! The necessary code might look like this (assuming none of the instances in the array is nil):
procedure TMyComponent.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('MyArray', ReadMyArray, WriteMyArray, true);
end;
procedure TMyComponent.ReadMyArray(Reader: TReader);
var
N: Integer;
begin
N := 0;
Reader.ReadListBegin;
while not Reader.EndOfList do begin
Reader.ReadListBegin;
FMyArray[N].Name := Reader.ReadString;
FMyArray[N].Value := Reader.ReadFloat;
Reader.ReadListEnd;
Inc(N);
end;
Reader.ReadListEnd;
end;
procedure TMyComponent.WriteMyArray(Writer: TWriter);
var
I: Integer;
begin
Writer.WriteListBegin;
for I := 0 to High(FMyArray) do begin
Writer.WriteListBegin;
Writer.WriteString(FMyArray[I].Name);
Writer.WriteFloat(FMyArray[I].Value);
Writer.WriteListEnd;
end;
Writer.WriteListEnd;
end;

Related

Is there an Indy server property equivalent to TCustomWinSocket.Data?

When I work with TServerSocket I can use the property Data to store a pointer to a class for example for each client.
Now I will use Indy TIdCmdTCPServer and I'd like to know if there is an equivalent property.
Yes, there is - the TIdContext.Data property. In TIdCmdTCPServer events that give you a TIdCommand parameter instead of a TIdContext parameter, you can access the TIdContext object from the TIdCommand.Context property. For example:
type
TMyClass = class
// add whatever you need...
end;
procedure TForm1.IdCmdTCPServer1Connect(AContext: TIdContext);
var
MyCls: TMyClass;
begin
MyCls := TMyClass.Create;
// initialize MyCls as needed...
AContext.Data := MyCls;
end;
procedure TForm1.IdCmdTCPServer1Disconnect(AContext: TIdContext);
begin
AContext.Data.Free;
AContext.Data := nil;
end;
procedure TForm1.IdCmdTCPServer1CommandHandlerCommand(ACommand: TIdCommand);
var
MyCls: TMyClass;
begin
MyCls := TMyClass(ACommand.Context.Data);
// use MyCls as needed...
end;
Indy also has another useful feature. You can derive a custom class from TIdServerContext, add whatever you want to it, and then assign it to the server's ContextClass property before activating the server. That way, you can simply typecast any TIdContext pointer to your class type when you need to access your custom members. For example:
type
TMyContext = class(TIdServerContext)
public
// add whatever you need...
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
//...
end;
destructor TMyContext.Destroy;
begin
//...
inherited;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
IdCmdTCPServer1.ContextsClass := TMyContext;
end;
procedure TForm1.IdCmdTCPServer1Connect(AContext: TIdContext);
var
MyCtx: TMyContext;
begin
MyCtx := TMyClass(AContext);
// initialize MyCtx as needed...
end;
procedure TForm1.IdCmdTCPServer1CommandHandlerCommand(ACommand: TIdCommand);
var
MyCtx: TMyContext;
begin
MyCtx := TMyClass(ACommand.Context);
// use MyCtx as needed...
end;
This way, you don't need to waste time and memory allocating a separate class per client, when you can use the one that the server already creates for you.

TObjectList<> Get item error

I'm trying to create TObjectList class in Delphi XE8, but i get errors when i try to get the value.
compiler error message: "[dcc32 Error] : can't access to private symbol {System.Generics.Collections}TList.GetItem"
Here is my code:
unit Unit2;
interface
uses
Classes, System.SysUtils, System.Types, REST.Types, System.JSON, Data.Bind.Components,
System.RegularExpressions, System.Variants,
Generics.Collections;
type
TTruc = class
public
libelle : string;
constructor Create(pLibelle : string);
end;
TListeDeTrucs = class(TObjectList<TTruc>)
private
function GetItem(Index: Integer): TTruc;
procedure SetItem(Index: Integer; const Value: TTruc);
public
function Add(AObject: TTruc): Integer;
procedure Insert(Index: Integer; AObject: TTruc);
procedure Delete(Index: Integer);
property Items[Index: Integer]: TTruc read GetItem write SetItem; default;
end;
implementation
{ TTruc }
constructor TTruc.Create(pLibelle: string);
begin
libelle := pLibelle;
end;
{ TListeDeTrucs }
function TListeDeTrucs.Add(AObject: TTruc): Integer;
begin
result := inherited Add(AObject);
end;
procedure TListeDeTrucs.Insert(Index: Integer; AObject: TTruc);
begin
inherited Insert(index, AObject);
end;
procedure TListeDeTrucs.Delete(Index: Integer);
begin
inherited delete(index);
end;
function TListeDeTrucs.GetItem(Index: Integer): TTruc;
begin
result := inherited GetItem(index);
end;
procedure TListeDeTrucs.SetItem(Index: Integer; const Value: TTruc);
begin
inherited setItem(index, value);
end;
end.
the testing code is :
procedure TForm1.Button1Click(Sender: TObject);
var
l : TListeDeTrucs;
i : integer;
Obj : TTruc;
begin
l := TListeDeTrucs.Create(true);
l.Add(TTruc.Create('one'));
l.Add(TTruc.Create('two'));
Obj := TTruc.Create('three');
l.Add(Obj);
for i := 0 to l.count - 1 do
begin
showMessage(l[i].libelle);
end;
L.Delete(0);
l.extract(Obj);
l.Free;
end;
How can i make it work ?
Well, GetItem, and indeed SetItem are private. Your code cannot see them. Private members can be seen only in the unit in which they are declared. You need to use members that are at least protected.
This compiles:
function TListeDeTrucs.GetItem(Index: Integer): TTruc;
begin
Result := inherited Items[Index];
end;
procedure TListeDeTrucs.SetItem(Index: Integer; const Value: TTruc);
begin
inherited Items[Index] := Value;
end;
In this case your class is a little pointless because none of the methods in your class vary behaviour from the base class. But peut-ĂȘtre your real class does more.

Convert member function pointer to function pointer in FreePascal

I want to pass to a GLUT function (glutKeyboardFunc) a pointer to a member function (TDisplayer.GlKeyboard). GLUT callback just accept function pointer. Is there a way to "pack" self pointer into the function ?
unit UDisplayer;
{$mode objfpc}
interface
type
TDisplayer = class(TObject)
public
constructor Create(x, y : Integer; caption : AnsiString);
destructor Destroy; override;
procedure GlKeyboard(key : Byte; x, y : Longint); cdecl;
private
winX : Integer;
winY : Integer;
end;
implementation
uses gl, glut, glext, UTools;
constructor TDisplayer.Create(x, y : Integer; caption : AnsiString);
var
cmd : array of PChar;
cmdCount : Integer;
keyboardCallback : pointer;
begin
winX := x;
winY := y;
cmdCount := 1;
SetLength(cmd, cmdCount);
cmd[0] := PChar(ParamStr(0));
glutInit(#cmdCount, #cmd);
glutInitDisplayMode(GLUT_DOUBLE or GLUT_RGB or GLUT_DEPTH);
glutInitWindowSize(x, y);
glutCreateWindow(PChar(caption));
glClearColor(0.0, 0.0, 0.0, 0);
//glutKeyBoardFunc(#self.glKeyBoard); <--- HERE
glutMainLoop;
end;
destructor TDisplayer.Destroy;
begin
inherited;
end;
procedure TDisplayer.GlKeyboard(key : Byte; x, y : Longint); cdecl;
begin
end;
end.
No. A method pointer is two pointers large, and a simple function pointer only one, so it simply won't fit.
If the callback system provides some "context" you can sometimes pass the instance into the context, and make a somewhat more general thunk like
function callme(context:pointer;x,y:integer);integer; cdecl;
begin
TTheClass(context).callme(x,y);
end;
Then pass "Self" as context when registering the callback. But it doesn't look like this callback setter has a context that is passed back to the callback when it is called.
In a first time, declare the callback as a global procedure.
It'll be a context-independent method, not relying on Self
type TDisplayer = class(TObject)
public
constructor Create(x, y : Integer; caption : AnsiString);
destructor Destroy; override;
private
winX : Integer;
winY : Integer;
end;
procedure GlKeyboard(key : Byte; x, y : Longint); cdecl;
Then since glutCreateWindow() returns an unique context, you can use it to associate it to your class instance. So you define an associative array wich allows to retrieve a TDisplayer instance using a GLUT window as Key:
type TCtxtArr = specialize TFPGMap<Integer,TForm>;
You add one as a global var which will be created and freed in the initialization and the finalization sections:
var
ctxtarray: TCtxtArr;
initialization
ctxtarray:= TCtxtArr.create;
finalization
ctxtarray.free;
end.
Then in TDisplayer.Create() you add an entry to the AA:
// id is a local integer.
id = glutCreateWindow(PChar(caption));
ctxtarray.Add(id, Self);
// assign the callback here or elsewhere
glutKeyBoardFunc(#glKeyBoard);
When your callback is called, you can retrieve the TDisplayer instance, so that you can access to its variables and methods:
procedure GlKeyboard(key : Byte; x, y : Longint); cdecl;
var
disp: TDisplayer;
id: integer;
begin
glutGetWindow(id);
disp := ctxtarray[id];
end;
Unfortunately, i cant test the answer as it seems to be part of a bigger program. However this sample works in an analog way:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, dialogs, fgl;
type
TForm1 = class;
TProc = procedure(x,y: integer);
TCtxtArr = specialize TFPGMap<Integer,TForm1>;
TForm1 = class(TForm)
constructor Create(TheOwner: TComponent); override;
procedure hello;
end;
procedure callback(x,y: integer);
var
Form1: TForm1; Proc: TProc;
ctxtarray: TCtxtArr;
implementation
{$R *.lfm}
constructor TForm1.Create(TheOwner: TComponent);
begin
inherited;
proc := #callback;
ctxtarray.Add(0,Self);
proc(0,0);
end;
procedure TForm1.hello;
begin
showmessage('hello');
end;
procedure callback(x, y: integer);
var
frm: TForm1;
begin
frm := ctxtarray.Data[0];
frm.hello;
end;
initialization
ctxtarray:= TCtxtArr.create;
finalization
ctxtarray.free;
end.
As a foot note: theorically FPC allows to define static class methods (similar to global procedures), but for some reason it seems that they cant be assigned to a global procedure pointer, at least it fails with FPC 2.6.4
You have to assemble some bytecode and keep wrapper with 'hardcoded' self pointer, which manages invocation stack:
procOfObj = packed record
method : pointer;
this : pointer;
end;
obj = packed object
procedure ASIOBufferSwitch(
ip: pointer; {the added IP artifact }
doubleBufferIndex: longint; directProcess: longbool); cdecl;
end;
cdeclProxy = packed object
procedure build( const src: procOfObj );
private
push : byte; push_arg: pointer;
call : byte; call_arg: pointer;
add_ret : longint;
end;
procedure cdeclProxy.build( const src: procOfObj );
begin
push := $68; push_arg := src.this;
call := $e8; call_arg := pointer( src.method - #call - 5 );
add_ret := $c304c483;
result := #push;
end;
var cdp : cdeclProxy;
o : obj;
begin
cdp.build( procOfObj( #o.ASIOBufferSwitch ))
pointer(... procedure var ...) := #cdp;
end.
Notice that provided example requires additional arg in method signature, but it allows to build wrapper without knowledge of arg count. If you do not want ip arg, you have to re-push all args again before calling actual method and then clean up stack inside wrapper.

Changing information in all Objects the same time

I'm a bit new with objects and I have really have been stuck on this, I hope you guys can help me.
I create a simple application to exemplify the problem I am having with Delphi.
I have an object that inherited from TButton, but in creation time I can assign a "Group" to this button, and after I want to be able to change the caption of all button created and to enable and disable it depending on the group that it belongs.
There are 5 button in the form:
Left G1 - Create a button to group one in the left side the form
Right G2 - Create a button to group two in the right side the form
Add caption - Add caption to all button created independent of the group (same caption to all)
Enable G1 - Enable all button that belongs to group one
Disable G1 - Disable all button that belongs to group one
What I want to do is to be able to create as many buttons I want for each different group and then change all the captions at once and enable and disable separate groups at once, this is a sample project from a much bigger application that have lots of objects created so go trough all the objects in the form would be very consuming it would be nice if the change could be made by the object not by the main form.
Please guys I don't want to anyone to make the work for me, I want someone to point me in the right direction, should I use a class even knowing that I can't change the individual properties of the objects is there a way around? Can I somehow implement it on the object or do I need to implement it on the unit calling those objects. Any pointer?
Many thanks in advance.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TSample = class(TButton)
private
class var count: integer;
protected
public
procedure increseCount;
constructor Create(AOwner: TComponent; Ypos, Group:Integer); overload;
class procedure rename(name: string);
class procedure enableGroup(Group: Integer; value: Boolean);
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
constructor TSample.Create(AOwner: TComponent; Ypos, Group:Integer);
begin
self.Create(AOwner);
self.Top := count *50;
self.Left := Ypos;
self.Tag := Group;
increseCount;
self.Parent := AOwner as TWinControl;
end;
procedure TSample.increseCount;
begin
count := count + 1;
end;
class procedure TSample.enableGroup(Group: Integer; value: Boolean);
begin
//???
end;
class procedure TSample.rename(name: string);
begin
//self.Caption := name; ???
end;
procedure TForm2.Button1Click(Sender: TObject);
var
left: TSample;
begin
left := TSample.Create(self, 24, 1);
end;
procedure TForm2.Button2Click(Sender: TObject);
var
right: TSample;
begin
right := TSample.Create(self, 200, 2);
end;
procedure TForm2.Button3Click(Sender: TObject);
begin
TSample.rename('Oi!');
end;
procedure TForm2.Button4Click(Sender: TObject);
begin
TSample.enableGroup(1, True);
end;
procedure TForm2.Button5Click(Sender: TObject);
begin
TSample.enableGroup(1, False);
end;
end.
Ok, after the hint from David I find the solution:
First I create an array the same kind of the object
Then I create a class function that create this object and save into this array
Now every time I need to access any of those objects I can just browse this list and change what need to be change.
Why I did this way? Before I was browsing all objects in my main form what was taking a lot of processing, doing this way I just have to browse objects of the kind I want to change.
Thanks I hope it can help others in the future.
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TSample = class(TButton)
private
class var count: integer;
class var List: Array of TSample;
protected
public
procedure increseCount;
constructor Create(AOwner: TComponent; Ypos, Group:Integer); overload;
class function CreateInstance(AOwner: TComponent; Ypos, Group:Integer): TSample; overload;
class procedure rename(name: string);
class procedure enableGroup(Group: Integer; value: Boolean);
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
class function TSample.CreateInstance(AOwner: TComponent; Ypos, Group:Integer): TSample;
var
i: Integer;
begin
i := Length(List)+1;
SetLength(List, i);
List[i-1] := self.Create(AOwner, Ypos, Group);
end;
constructor TSample.Create(AOwner: TComponent; Ypos, Group:Integer);
begin
self.Create(AOwner);
self.Top := count *50;
self.Left := Ypos;
self.Tag := Group;
increseCount;
self.Parent := AOwner as TWinControl;
end;
procedure TSample.increseCount;
begin
count := count + 1;
end;
class procedure TSample.enableGroup(Group: Integer; value: Boolean);
var
i: Integer;
begin
for i := 0 to Length(List)-1 do
if List[i].Tag = Group then
List[i].Enabled := value;
end;
class procedure TSample.rename(name: string);
var
i: Integer;
begin
for i := 0 to Length(List)-1 do
List[i].Caption := name;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
left: TSample;
begin
left := TSample.CreateInstance(self, 24, 1);
end;
procedure TForm2.Button2Click(Sender: TObject);
var
right: TSample;
begin
right := TSample.CreateInstance(self, 200, 2);
end;
procedure TForm2.Button3Click(Sender: TObject);
begin
TSample.rename('Oi!');
end;
procedure TForm2.Button4Click(Sender: TObject);
begin
TSample.enableGroup(1, True);
end;
procedure TForm2.Button5Click(Sender: TObject);
begin
TSample.enableGroup(1, False);
end;
end.

Scan all classes for a given custom attribute

I'm looking for a way of scanning all loaded classes for classes which contain a custom attribute, if possible, without using RegisterClass().
at first you have to create TRttiContext, then get all loaded classes using getTypes. after that you can filter types by TypeKind = tkClass;
next step is to enumerate attributes and check if it has your attribute;
attribute and test-class delcaration:
unit Unit3;
interface
type
TMyAttribute = class(TCustomAttribute)
end;
[TMyAttribute]
TTest = class(TObject)
end;
implementation
initialization
TTest.Create().Free(); //if class is not actually used it will not be compiled
end.
and then find it:
program Project3;
{$APPTYPE CONSOLE}
uses
SysUtils, rtti, typinfo, unit3;
type TMyAttribute = class(TCustomAttribute)
end;
var ctx : TRttiContext;
t : TRttiType;
attr : TCustomAttribute;
begin
ctx := TRttiContext.Create();
try
for t in ctx.GetTypes() do begin
if t.TypeKind <> tkClass then continue;
for attr in t.GetAttributes() do begin
if attr is TMyAttribute then begin
writeln(t.QualifiedName);
break;
end;
end;
end;
finally
ctx.Free();
readln;
end;
end.
output is Unit3.TTest
Call RegisterClass to register a class with the streaming system.... Once classes are registered, they can be loaded or saved by the component streaming system.
so if you don't need component streaming (just find classes with some attribute), there is no need to RegisterClass
You can use the new RTTI functionality exposed by the Rtti unit.
var
context: TRttiContext;
typ: TRttiType;
attr: TCustomAttribute;
method: TRttiMethod;
prop: TRttiProperty;
field: TRttiField;
begin
for typ in context.GetTypes do begin
for attr in typ.GetAttributes do begin
Writeln(attr.ToString);
end;
for method in typ.GetMethods do begin
for attr in method.GetAttributes do begin
Writeln(attr.ToString);
end;
end;
for prop in typ.GetProperties do begin
for attr in prop.GetAttributes do begin
Writeln(attr.ToString);
end;
end;
for field in typ.GetFields do begin
for attr in field.GetAttributes do begin
Writeln(attr.ToString);
end;
end;
end;
end;
This code enumerates attributes associated with methods, properties and fields, as well as with types. Naturally you will want to do more than Writeln(attr.ToString), but this should give you an idea for how to proceed. You can test for your specific attribute in the normal way
if attr is TMyAttribute then
....