Browse Source

* Add MethodName, FieldAddress

michael 6 years ago
parent
commit
3a623b5dc3
1 changed files with 49 additions and 0 deletions
  1. 49 0
      packages/rtl/system.pas

+ 49 - 0
packages/rtl/system.pas

@@ -140,6 +140,7 @@ type
     class property UnitName: String read FUnitName;
     Class function MethodName(aCode : Pointer) : String;
     Class function MethodAddress(aName : String) : Pointer;
+    Class Function FieldAddress(aName : String) : Pointer;
     Class Function ClassInfo : Pointer;
 
     procedure AfterConstruction; virtual;
@@ -847,12 +848,35 @@ end;
 Class function TObject.MethodName(aCode : Pointer) : String;
 
 begin
+  Result:='';
+  if aCode=Nil then
+    exit;
+asm
+  var i = 0;
+  var TI = this.$rtti;
+  // Callback ?
+  if ((typeof aCode["fn"] === "string") && (typeof aCode["scope"] === "object")) return aCode["fn"];
+  // Not a callback, check rtti
+  while ((Result === "") && (TI != null)) {
+    i = 0;
+    while ((Result === "") && (i < TI.methods.length)) {
+      if (this[TI.getMethod(i).name] === aCode)
+        Result=TI.getMethod(i).name;
+      i += 1;
+    };
+    if (Result === "") TI = TI.ancestor;
+  };
+  return Result;
+end;
 end;
 
 Class function TObject.MethodAddress(aName : String) : Pointer;
 
 // We must do this in asm, because the typinfo unit is not available.
 begin
+  Result:=Nil;
+  if AName='' then
+    exit;
 asm
   var i = 0;
   var TI = this.$rtti;
@@ -872,6 +896,31 @@ asm
 end;
 end;
 
+class function TObject.FieldAddress(aName: String): Pointer;
+
+begin
+  Result:=Nil;
+  asm
+    var aClass = null;
+    var i = 0;
+    var ClassTI = null;
+    var myName = aName.toLowerCase();
+    var MemberTI = null;
+    aClass = this.$class;
+    while (aClass !== null) {
+      ClassTI = aClass.$rtti;
+      for (var $l1 = 0, $end2 = ClassTI.fields.length - 1; $l1 <= $end2; $l1++) {
+        i = $l1;
+        MemberTI = ClassTI.getField(i);
+        if (MemberTI.name.toLowerCase() === myName) {
+           return MemberTI;
+        };
+      };
+      aClass = aClass.$ancestor ? aClass.$ancestor : null;
+    };
+  end;
+end;
+
 Class Function TObject.ClassInfo : Pointer;
 
 begin