[fpc-pascal] Read Field names from VMT

[Michael Van Canneyt]

On Wed, 31 Jan 2024, Amir--- via fpc-pascal wrote:

>
>> Without more info (declaration of ChildTClass, declaration of the 
>> constructor
>> of that class etc), it is not possible to comment.
>> 
>> We need a complete compilable code sample to provide you with more insight.
>> 
> Please have a look at the attachment.

The constructor of TObject is not virtual, in difference with the destructor.

Given the definitions

   ChildObj: TObject;
   ChildTClass: TClass;

The following statement

   ChildObj := ChildTClass.Create;

will always use the TObject.Create, since it is not virtual.

In general, you cannot use TObject for this kind of thing.

For this to work, you need to create a descendent of TObject with a virtual
constructor (call it TMyObject) of known signature, and do

   ChildObj: TMyObject;
   ChildTClass: TMyClass; // class of TMyobject

then

   ChildObj := ChildTClass.Create;

will take the correct overridden constructor.

Your code is also incomplete in the sense that it will only work for classes
with a constructor without arguments. 
If a overloaded constructor exists which takes arguments (like TComponent), 
it will not be called and the class will not be instantiated correctly.
But maybe that will not be your use-case.

I attached a version of your program that works and has no memleaks.

Michael.
-------------- next part --------------
program FieldAddress;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}
  cthreads,
  {$ENDIF}
  Classes, TypInfo
  { you can add units after this };

type
  {$M+}

  { TValue }
  TMyObject = class (TObject)
    constructor create; virtual;
  end;
  TMyClass = class of TMyObject;
  
  TValue = class(TMyObject)
  private
    FV: PInteger;
  public
    constructor Create; override;
    destructor destroy; override;
  end;

  { TParam }

  TParam = class(TObject)
  
  public
    destructor destroy; override;
  
  published
    V1: TValue;
    V2: TValue;

  end;

procedure Process(vft: PVmtFieldTable; Obj: TObject);
var
  vfe: PVmtFieldEntry;
  i: SizeInt;
  Name: AnsiString;
  ChildObj: TMyObject;
  ChildTClass: TMyClass;
  FieldClass : TClass;

begin
  if vft=nil then exit;
  Writeln(vft^.Count, ' field(s) with ', vft^.ClassTab^.Count, ' type(s)');
  for i := 0 to vft^.Count - 1 do
  begin
     vfe := vft^.Field[i];
     Name := vfe^.Name;

     Writeln(i, ' -> ', vfe^.Name, ' @ ', vfe^.FieldOffset, ' of type ', vft^.ClassTab^.ClassRef[vfe^.TypeIndex - 1]^.ClassName);

     FieldClass := vft^.ClassTab^.ClassRef[vfe^.TypeIndex - 1]^;
     if FieldClass.InheritsFrom(TMyObject) then
     begin
       Writeln('Inherits');
       ChildTClass := TMyClass(FieldClass);
       WriteLn('ChidTClass: ', ChildTClass.ClassName);
       ChildObj := ChildTClass.Create;
       if ((ChildObj as TValue).FV = nil) or ((ChildObj as TValue).FV^ <> 1) then
       begin
         WriteLn('ERROR');
         Halt(1);
       end;
       writeln('Calling sub');
       TObject(Obj.FieldAddress(Name)^):=ChildObj;
       Process(
         PVmtFieldTable(PVMT(ChildTClass)^.vFieldTable),
         ChildObj
       );
     end;
   end;

end;


{ TValue }

constructor TMyObject.create;
begin
end;

constructor TValue.Create;
begin
  inherited Create;
   Writeln('Called');
  FV := New(PInteger);
  FV^ := 1;

end;

destructor TValue.Destroy; 
begin
  dispose(FV);
  inherited;
end;

{ TParam}

destructor TParam.Destroy;

begin
  V1.Free;
  V2.Free;
  Inherited;
end;

var
  Param: TParam;

begin
  Param := TParam.Create;

  Process(PVmtFieldTable(PVMT(TParam)^.vFieldTable), Param);

  Param.Free;
end.