how to copy data from one class into a second class using operator overloading with DELPHI ?
my dummy app goes like this :
type
TClass_A = class
a: String;
end;
TClass_B = class(TClass_A)
b: String;
end;
implementation
procedure TForm1.Button1Click(Sender: TObject);
var
a: TClass_A;
b: TClass_B;
begin
a := TClass_A.Create;
b := TClass_B.create;
b := a; // <<-- What code should be here? Can I overload := operator?
end;
The assignment operator cannot be overloaded in Delphi.
You will need to introduce a method to perform the copying. An example of how this might be done is TPersistent.Assign. It would be perfectly reasonable for you to derive from TPersistent and override the virtual Assign method to implement the desired functionality.
Here is a small example of how to do this with new style RTTI (D2010 and higher).
Please note that this is a very basic example which only copies fields (not properties) and works best with basic classes (do not use this with TComponent), the fields in the destination object must be the same type. FYI, there are better examples out there :)
uses
Rtti,...
function CopyObject(const FromObj, ToObj: TObject): Boolean;
var
Ctx : TRTTIContext;
FromObjType : TRttiType;
ToObjType : TRttiType;
FromField : TRttiField;
ToField : TRttiField;
begin
Result := False;
FromObjType := Ctx.GetType(FromObj.ClassInfo);
ToObjType := Ctx.GetType(ToObj.ClassInfo);
for FromField in FromObjType.GetFields do
begin
ToField := ToObjType.GetField(FromField.Name);
if Assigned(ToField) then
begin
if ToField.FieldType = FromField.FieldType then
ToField.SetValue(ToObj, FromField.GetValue(FromObj));
Result := True;
end;
end;
end;
Related
I am putting some logic into the project source before form creation. If some conditions are met, I proceed with form creation. The logic is generating data that I need to pass to the form, let'say some variable. I declared these variables inside the public section of the form, but I can't find a way to pass these values, since the variables need the form to be created to exist.
Is there a way? I am using Delphi 2007.
I suggest to set these variables once the condition is met.
Run your logic
Check the condition
Create form
Assign variables on the form
In the project source:
var
MyVariable1 : integer;
MyVariable2 : integer;
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
//some logic to assign variables
//...
//create form and set variables only if condition is met, example:
if(MyVariable1 + MyVariable2 > 10) then
begin
Application.CreateForm(TForm1, Form1);
Form1.MyVariable1 := MyVariable1;
Form1.MyVariable2 := MyVariable2;
end;
Application.Run;
end.
In the form source:
TForm1 = class(TForm)
private
{ Private declarations }
public
MyVariable1 : integer;
MyVariable2 : integer;
{ Public declarations }
end;
How you're creating the form?
You can do something like this:
f := TMyForm.Create(Application)
f.MyProperty := 10;
f.Show;
Regards.
You can declare a global variable in form unit and use it in the form unit
you can set global var every where you want
TForm9 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
MyLocalVar : Int64;
end;
var
Form9: TForm9;
MyGlobalVar : Int64;
implementation
{$R *.dfm}
procedure TForm9.FormCreate(Sender: TObject);
begin
MyLocalVar := MyGlobalVar;
end;
I'm developing a component that works on several classes.
In order to allow adding the list of managed classes, I've written a TCollection's inherited class in which each item (inherited from TCollectionItem) defines a published "TargetClassName" property.
The "TargetClassName" property's setter function, calls the following function in order to find the corrisponding TClass:
function FindAnyClass(const Name: string): TClass;
var
ctx: TRttiContext;
typ: TRttiType;
list: TArray<TRttiType>;
begin
Result := nil;
ctx := TRttiContext.Create;
list := ctx.GetTypes;
for typ in list do
begin
if typ.IsInstance and (EndsText(Name, typ.Name)) then
begin
Result := typ.AsInstance.MetaClassType;
break;
end;
end;
ctx.Free;
end;
(Thanks to Dalija Prasnikar for writing the function Get class by its name in Delphi).
Now, I'm wondering if there's a better way to allow adding classes to a TCollectionItem at design time.. What do you think about it?
Hope to read interesting solutions!
Thanks to all.
in creation on TCollection You need To introduce Collation Class
it's Posible in two way
1 : hard coded in create time X := TMycollation.Create(TMyCollationClass)
2 : your solution X := TMycollation.Create(FindAnyClass('TMyCollationClass'));
I would like to write a function that accepts a classname and results the corresponding TClass. I've noticed that, System.Classes.GetClass function doesn't works if the classname isn't registered.
Example:
if(GetClass('TButton') = nil)
then ShowMessage('TButton not found!')
else ShowMessage('TButton found!');
The previous code always shows:
TButton not found!
Is there something missing?
You can get unregistered class used in Delphi application via extended RTTI. But you have to use fully qualified class name to find the class. TButton will not be enough, you have to search for Vcl.StdCtrls.TButton
uses
System.Classes,
System.RTTI;
var
c: TClass;
ctx: TRttiContext;
typ: TRttiType;
begin
ctx := TRttiContext.Create;
typ := ctx.FindType('Vcl.StdCtrls.TButton');
if (typ <> nil) and (typ.IsInstance) then c := typ.AsInstance.MetaClassType;
ctx.Free;
end;
Registering class ensures that class will be compiled into Delphi application. If class is not used anywhere in code and is not registered, it will not be present in application and extended RTTI will be of any use in that case.
Additional function that will return any class (registered or unregistered) without using fully qualified class name:
uses
System.StrUtils,
System.Classes,
System.RTTI;
function FindAnyClass(const Name: string): TClass;
var
ctx: TRttiContext;
typ: TRttiType;
list: TArray<TRttiType>;
begin
Result := nil;
ctx := TRttiContext.Create;
list := ctx.GetTypes;
for typ in list do
begin
if typ.IsInstance and (EndsText(Name, typ.Name)) then
begin
Result := typ.AsInstance.MetaClassType;
break;
end;
end;
ctx.Free;
end;
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.
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
....