paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-27 11:10:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Alfred Glänzer, fix FindComponentClass to use actual typinfo structures. Fixes issue #41000

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-11-09 09:45:40 +01:00
parent bdb3d097b5
commit 6e73a3b0e1
1 changed files with 45 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
rtl/objpas/classes/reader.inc
View File

@ -612,71 +612,37 @@ begin
end; end;
{****************************************************************************} {****************************************************************************}
{* TREADER *} {* TREADER *}
{****************************************************************************} {****************************************************************************}
type
TFieldInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
FieldOffset: SizeUInt;
ClassTypeIndex: Word; // start at 1
Name: ShortString;
end;
PFieldInfo = ^TFieldInfo;
PPersistentClass = ^TPersistentClass;
PersistentClassRef = PPersistentClass;
TFieldClassTable =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
Count: Word;
Entries: array[{$ifdef cpu16}0..16384 div sizeof(PersistentClassRef){$else}Word{$endif}] of PersistentClassRef;
end;
PFieldClassTable = ^TFieldClassTable;
TFieldTable =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
FieldCount: Word;
ClassTable: PFieldClassTable;
Fields: array[0..0] of TFieldInfo;
end;
PFieldTable = ^TFieldTable;
function GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass; function GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass;
var var
ShortClassName: shortstring; ShortClassName: shortstring;
ClassType: TClass; ClassType: TClass;
ClassTable: PFieldClassTable;
i: Integer; i: Integer;
FieldTable: PFieldTable; FieldTable: PVmtFieldTable;
ClassTable: PVmtFieldClassTab;
begin begin
// At first, try to locate the class in the class tables // At first, try to locate the class in the class tables
ShortClassName := ClassName; ShortClassName := ClassName;
ClassType := Instance.ClassType; ClassType := Instance.ClassType;
while ClassType <> TPersistent do while ClassType <> TPersistent do
begin begin
FieldTable := PFieldTable(PVmt(ClassType)^.vFieldTable); FieldTable := PVmtFieldTable(PVmt(ClassType)^.vFieldTable);
if Assigned(FieldTable) then if FieldTable<>nil then
begin
ClassTable := PVmtFieldClassTab(FieldTable^.ClassTab);
if ClassTable<>nil then
begin begin
ClassTable := FieldTable^.ClassTable;
for i := 0 to ClassTable^.Count - 1 do for i := 0 to ClassTable^.Count - 1 do
begin begin
Result := ClassTable^.Entries[i]^; Result := TPersistentClass(Pointer(ClassTable^.ClassRef[i])^);
if Result.ClassNameIs(ShortClassName) then if Result.ClassNameIs(ShortClassName) then
exit; exit;
end; end;
end; end;
end;
// Try again with the parent class type // Try again with the parent class type
ClassType := ClassType.ClassParent; ClassType := ClassType.ClassParent;
end; end;
@ -1919,12 +1885,12 @@ var
function FindInFieldTable(Instance: TComponent): TComponentClass; function FindInFieldTable(Instance: TComponent): TComponentClass;
var var
aClassType: TClass; aClassType : TClass;
FieldTable: PFieldTable; FieldTable : PVmtFieldTable;
ClassTable: PFieldClassTable; ClassTable : PVmtFieldClassTab;
i: Integer; FieldInfo : PVmtFieldEntry;
FieldInfo: PFieldInfo; PersistenClass : TPersistentClass;
PersistenClass: TPersistentClass; i : Integer;
begin begin
//writeln('FindInFieldTable Instance=',Instance.Name,':',Instance.UnitName,'>',Instance.ClassName,' ShortName="',ShortName,'" ShortClassName="',ShortClassName,'"'); //writeln('FindInFieldTable Instance=',Instance.Name,':',Instance.UnitName,'>',Instance.ClassName,' ShortName="',ShortName,'" ShortClassName="',ShortClassName,'"');
Result:=nil; Result:=nil;
@ -1933,30 +1899,25 @@ var
aClassType := Instance.ClassType; aClassType := Instance.ClassType;
while aClassType <> TPersistent do while aClassType <> TPersistent do
begin begin
FieldTable := PFieldTable(PVmt(aClassType)^.vFieldTable); FieldTable := PVmtFieldTable(PVmt(aClassType)^.vFieldTable);
if Assigned(FieldTable) then if FieldTable<>nil then
begin begin
ClassTable := FieldTable^.ClassTable; ClassTable := PVmtFieldClassTab(FieldTable^.ClassTab);
FieldInfo := @FieldTable^.Fields[0]; if ClassTable<>nil then
for i := 0 to FieldTable^.FieldCount - 1 do
begin begin
//writeln('FindInFieldTable Instance=',Instance.ClassName,' FieldInfo ',i,'/',FieldTable^.FieldCount,' ',FieldInfo^.Name); for i := 0 to FieldTable^.Count - 1 do
begin
FieldInfo := FieldTable^.Field[i];
if ShortCompareText(FieldInfo^.Name,ShortName)=0 then if ShortCompareText(FieldInfo^.Name,ShortName)=0 then
begin begin
PersistenClass := ClassTable^.Entries[FieldInfo^.ClassTypeIndex-1]^; PersistenClass := TPersistentClass(Pointer(ClassTable^.ClassRef[FieldInfo^.TypeIndex-1])^);
//writeln('FindInFieldTable Found Field "',FieldInfo^.Name,'" Class="',PersistenClass.UnitName,'>',PersistenClass.ClassName,'"');
if PersistenClass.ClassNameIs(ShortClassName) if PersistenClass.ClassNameIs(ShortClassName)
and PersistenClass.InheritsFrom(TComponent) then and PersistenClass.InheritsFrom(TComponent) then
exit(TComponentClass(PersistenClass)); exit(TComponentClass(PersistenClass));
end; end;
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
FieldInfo := PFieldInfo(PByte(@FieldInfo^.Name) + 1 + Length(FieldInfo^.Name));
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
FieldInfo := PFieldInfo(align(PByte(@FieldInfo^.Name) + 1 + Length(FieldInfo^.Name), sizeof(SizeUInt)));
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
end; end;
end; end;
// Try again with the parent class type end;
aClassType := aClassType.ClassParent; aClassType := aClassType.ClassParent;
end; end;
@ -1964,13 +1925,15 @@ var
aClassType := Instance.ClassType; aClassType := Instance.ClassType;
while aClassType <> TPersistent do while aClassType <> TPersistent do
begin begin
FieldTable := PFieldTable(PVmt(aClassType)^.vFieldTable); FieldTable := PVmtFieldTable(PVmt(aClassType)^.vFieldTable);
if Assigned(FieldTable) then if FieldTable<>nil then
begin
ClassTable := PVmtFieldClassTab(FieldTable^.ClassTab);
if ClassTable<>nil then
begin begin
ClassTable := FieldTable^.ClassTable;
for i := 0 to ClassTable^.Count - 1 do for i := 0 to ClassTable^.Count - 1 do
begin begin
PersistenClass := ClassTable^.Entries[i]^; PersistenClass := TPersistentClass(Pointer(ClassTable^.ClassRef[i])^);
if PersistenClass.ClassNameIs(ShortClassName) if PersistenClass.ClassNameIs(ShortClassName)
and PersistenClass.InheritsFrom(TComponent) then and PersistenClass.InheritsFrom(TComponent) then
begin begin
@ -1979,6 +1942,7 @@ var
end; end;
end; end;
end; end;
end;
// Try again with the parent class type // Try again with the parent class type
aClassType := aClassType.ClassParent; aClassType := aClassType.ClassParent;
end; end;