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

* Patch from Lipinast Lekrisov to implement indexed properties

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-12-18 22:00:11 +01:00
parent 060c06c052
commit b8bf81bc65
1 changed files with 61 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
packages/rtl-objpas/tests/tests.rtti.invoke.pas
View File

@ -58,6 +58,7 @@ type
{ TTestInvoke } { TTestInvoke }
TTestInvoke = class(TTestInvokeBase) TTestInvoke = class(TTestInvokeBase)
private
published published
procedure TestShortString; procedure TestShortString;
procedure TestAnsiString; procedure TestAnsiString;
@ -71,6 +72,10 @@ type
procedure TestTObject; procedure TestTObject;
procedure TestCasts; procedure TestCasts;
procedure TestClassConstructor;
procedure TestInheritedClassConstructor;
procedure TestClassProperty;
procedure TestIndexedProperty;
end; end;
{ TTestInvokeIntfMethods } { TTestInvokeIntfMethods }
@ -1571,6 +1576,62 @@ begin
end; end;
end; end;
procedure TTestInvoke.TestClassConstructor;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass := aclassType.GetMethod('Create').Invoke(TValue.Empty, [459, 982]).AsObject as TTestAttr2Class;
AssertTrue('Created from nothing TTestClass is incorrect', (testClass.fa = 459) and (testClass.fa2 = 982));
end;
procedure TTestInvoke.TestInheritedClassConstructor;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass := aclassType.GetMethod('Create').Invoke(TInherited2Class, [116, 904]).AsObject as TTestAttr2Class;
AssertTrue('TInheritedClass created via an ancestor constructor is incorrect',(testClass is TInherited2Class) and (testClass.fa = 116) and (testClass.fa2 = 904));
end;
procedure TTestInvoke.TestClassProperty;
var
context: TRttiContext;
aclassType: TRttiType;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
aclassType.GetProperty('StaticProp').SetValue(nil, 4539);
AssertTrue('Class property is set or got incorrectly via methods',aclassType.GetProperty('StaticProp').GetValue(nil).AsInteger = 4539);
end;
procedure TTestInvoke.TestIndexedProperty;
var
context: TRttiContext;
aclassType: TRttiType;
testClass: TTestAttr2Class;
begin
context := TRttiContext.Create(False);
aclassType := context.GetType(TTestAttr2Class);
testClass:=TTestAttr2Class.Create(784,328);
aclassType.GetIndexedProperty('TestIProp').SetValue(testClass, [653, 796], testClass);
testClass := TTestAttr2Class(aclassType.GetIndexedProperty('TestIProp').GetValue(testClass, [384, 170]).AsObject);
AssertTrue('The getter of an indexed property for a class is incorrectly called', (testClass.fa = 384) and (testClass.fa2 = 170));
end;
procedure TTestInvoke.TestTObject; procedure TTestInvoke.TestTObject;
procedure DoStaticInvokeTestClassCompare( procedure DoStaticInvokeTestClassCompare(