Delphi 创建建具有“反射调用”功能的类

最新推荐文章于 2025-03-14 15:32:10 发布
最新推荐文章于 2025-03-14 15:32:10 发布
阅读量3.5k 收藏 3
点赞数
分类专栏： Delphi 文章标签： delphi integer function string destructor constructor
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.youkuaiyun.com/LocustWei/article/details/855784
版权

有的时候你会希望自己定义的一个Class在运行期能增加一个property、function，或者一个方法能完全改变他的行为，又或者你希望通过方法名来调用方法（类似JAVA）。

这样的效果可以利用AutoObject的后绑定特性来实现。

第一步、模拟实现一个AutoObject。

其实关键部分是要实现IDispatch的GetIDsOfNames（通过函数（属性）名称获取函数ID），和Invoke（调用指定DispID的方法）。完成之后，TRefClass便有了后帮定特性。可以赋值给Variant变量。

第二步、用一个List 保存增加的属性名称、方法名称、方法指针。以便GetIDsOfNames能找到指定的方法。

第三步、对已知方法调用、属性赋值处理比较简单。对动态增加的方法，由于参数未知，和参数的传递方式不同，处理起来相对困难（下面的例子支持简单参数类型Stdcall。

  TRefClass = class(TInterfacedObject, IDispatch)
  private
    function CallFunction(ProcAddress: Pointer; var Params: TDispParams): variant;
  protected
    FList: TCustomList;
    function GetFieldValue(DataField: String): Variant; virtual;
    procedure SetFieldValue(DataField: String; Value: Variant); virtual;
    function ClassMapp: variant;
    procedure AddProperty(Attribute: String; Default: variant);
    function GetProperty(Attribute: String): variant;
    function FindProperty(DataField: String): boolean;
    procedure AddProcedure(ProName: string; Address: Pointer; OfObject: TObject);

    {IDispatch}
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;

  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
    class function CreateAsAutoObject(AOwner: TComponent): variant;
  end;
 implementation
procedure TRefClass .AddProcedure(ProName: string; Address: Pointer;
  OfObject: TObject);
var
  pMethod: ^TSetPropertyProc;
begin
  pMethod := AllocMem(SizeOf(TSetPropertyProc));
  TMethod(pMethod^).Data := OfObject;
  TMethod(pMethod^).Code := Address;

  FList.Add(ProName, PointerToVariant(pMethod));
end;

procedure TRefClass .AddProperty(Attribute: String; Default: variant);
begin
  FList.Add(Attribute, Default);
end;
function TRefClass .CallFunction(ProcAddress: Pointer;
  var Params: TDispParams): variant;

  function GetParamAdrs(Value: Variant): Pointer;
  var
    s: PString;
    k: PInteger;
    F: PExtended;
  begin
    case TVarData(Value).VType of
      varInteger, varSmallint, varSingle:
        begin
          New(k);
          K^ := Value;
          Result := K;
        end;
      varOleStr, varString:
        begin
          New(S);
          s^ := Value;
          Result := S;
        end;
      varDouble, varCurrency:
        begin
          New(F);
          F^ := Value;
          Result := F;
        end;
      else
        Result := nil;
    end;
  end;
var
  i: Integer;
  pParams: array of Pointer;
  p: TMethod;
  pCount: Integer;
begin
  pCount := Params.cArgs;
  SetLength(pParams, pCount);
  FillChar(pParams[0], pCount*Sizeof(Pointer), 0);
  p := TMethod(ProcAddress^);

  for i:=pCount-1 downto 0 do
  begin
    pParams[pCount-1-i] := GetParamAdrs(Variant(DispParams(Params).rgvarg^[i]));
  end;

  asm
//    push eax
//    push ecx
//    push edx
//    //push p.Data
    cmp pCount, 1
    JB @exec
    JE @One
    cmp pCount, 2
    JE @two
    @ThreeUp:
      CLD
      mov ecx, pCount
      sub ecx, 2
      mov edx, 4
      add edx, 4
    @loop:
      mov eax, [pParams]
      mov eax, [eax]+edx
      mov eax, [eax]
      push eax
      add edx, 4
      Loop @loop
    @Two:
      mov ecx, [pParams]
      mov ecx, [ecx]+4
      mov ecx, [ecx]
    @One:
      mov edx, [pParams]
      mov edx, [edx]
      mov edx, [edx]
    @exec:
      mov eax, p.Data
      test eax, eax
      je @1
      jne @call
      @1:
        mov eax, edx
        mov edx, ecx
        pop ecx
        jmp @call
      @call:
        call P.Code
//    pop edx
//    pop ecx
//    pop eax
  end;

  for i:=0 to pCount-1 do
    Dispose(pParams[i]);
end;

function TRefClass .ClassMapp: variant;
begin
  result := Self as IDispatch;
end;

constructor TRefClass .Create(AOwner: TComponent);
begin
  inherited Create;
  FOwner := AOwner;
  FList := TCustomList.Create();
end;

class function TRefClass .CreateAsAutoObject(AOwner: TComponent): variant;
begin
  result := Create(AOwner).ClassMapp;
end;

destructor TRefClass .Destroy;
begin
  FList.free;
  inherited;
end;

function TRefClass .FindProperty(DataField: String): boolean;
begin
  result := false;
end;

function TRefClass .GetFieldValue(DataField: String): Variant;
var
  P: PPropInfo;
  V: variant;
  TypeData: PTypeData;
  PFunction: ^TGetPropertyFunction;
  k: integer;
begin
  V := FList[DataField];
  if TVarData(V).Reserved1=1 then
  begin
    P := VariantToPointer(V);
    case P^.PropType^.Kind of
      tkInteger, tkChar, tkWChar, tkClass:
        result := GetOrdProp(FOwner, P);
      tkEnumeration:
        begin
          TypeData := GetTypeData(P^.PropType^);
          if TypeData^.BaseType^ = TypeInfo(Boolean) then
            Result := Boolean(GetOrdProp(FOwner, P))
          else
            Result := GetOrdProp(FOwner, P);
        end;
      tkFloat:
        Result := GetFloatProp(FOwner, P);
      tkString, tkLString, tkWString:
        Result := GetStrProp(FOwner, P);
      tkSet:
        Result := GetSetProp(FOwner, P);
      tkMethod:
        Result := P^.PropType^.Name;
      tkVariant:
        Result := GetVariantProp(FOwner, P);
      tkInt64:
        Result := GetInt64Prop(FOwner, P) + 0.0;
      tkDynArray,
      tkArray,
      tkRecord,
      tkInterface:;
    end;
  end
  else
  begin
    k := FList.IndexOf(Format('Get%s', [DataField]));
    if k<>-1 then
    begin
      PFunction := VariantToPointer(FList.Items[k]);
      V := PFunction^;
    end;
    result := V;
  end;
end;

function TRefClass .GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
const
  FUNCLIST: array[1..4] of String =
    ('AddProperty', 'GetProperty', 'FindProperty', 'AddProcedure');
var
  S: String;
  DispID: integer;
  i: integer;
begin
  s := WideString(POleStrList(Names)^[0]);
  DispID := 0;
  for i := 1 to 4 do
    if CompareText(S, FUNCLIST[i])=0 then
    begin
      DispID := -1*i;
      break;
    end;
  if DispID = 0 then
  begin
    DispID := FList.IndexOf(S);

    if DispID = -1 then
    begin
      result := E_NOTIMPL;
      exit;
    end;
  end;
  PDispIdList(DispIDs)^[0] := DispID;
  result := S_OK;
end;

function TRefClass .GetProperty(Attribute: String): variant;
begin
  result := GetFieldValue(Attribute);
end;

function TRefClass .GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  result := S_OK;
end;

function TRefClass .GetTypeInfoCount(out Count: Integer): HResult;
begin
  result := S_OK;
end;

function TRefClass .Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
Var
  V: Variant;
  P: Pointer;
begin
  case DispID of
    -1:
      begin
        if PDispParams(@Params)^.cArgs=1 then
          AddProperty(OleVariant(PDispParams(@Params).rgvarg^[0]), NULL)
        else
          AddProperty(OleVariant(PDispParams(@Params).rgvarg^[1]), OleVariant(PDispParams(@Params).rgvarg^[0]))
      end;
    -2:
      V := FindProperty(OleVariant(PDispParams(@Params).rgvarg^[0]));
    -3:
      V := GetProperty(OleVariant(PDispParams(@Params).rgvarg^[0]));
    -4:
      if PDispParams(@Params)^.cArgs=2 then
        AddProcedure(OleVariant(PDispParams(@Params).rgvarg^[1]),
          VariantToPointer(OleVariant(PDispParams(@Params).rgvarg^[0])), nil)
      else if PDispParams(@Params)^.cArgs=3 then
        AddProcedure(OleVariant(PDispParams(@Params).rgvarg^[2]),
          VariantToPointer(OleVariant(PDispParams(@Params).rgvarg^[1])),
          VariantToPointer(OleVariant(PDispParams(@Params).rgvarg^[0])));
    else
    begin
      if (Flags and DISPATCH_PROPERTYGET) = DISPATCH_PROPERTYGET then
        V := GetFieldValue(FList.Names[DispID])
      else if (Flags and DISPATCH_PROPERTYPUT) = DISPATCH_PROPERTYPUT then
        SetFieldValue(FList.Names[DispID], OleVariant(PDispParams(@Params).rgvarg^[0]))
      else
      begin
        V := FList.Items[DispID];
        P := VariantToPointer(V);
        V := CallFunction(P, TDispParams(Params));
      end;
    end;
  end;
  if assigned(VarResult) then
    PVariant(VarResult)^ := V;
  result := S_OK;
end;

procedure TRefClass .SetFieldValue(DataField: String; Value: Variant);
  function RangedValue(const AMin, AMax: Int64): Int64;
  begin
    Result := Trunc(Value);
    if Result < AMin then
      Result := AMin;
    if Result > AMax then
      Result := AMax;
  end;
var
  PropInfo: PPropInfo;
  TypeData: PTypeData;
  V: variant;
  PProcedure: ^TSetPropertyProc;
  k: integer;
begin
  V := FList[DataField];

  if TVarData(V).Reserved1=1 then
  begin
    PropInfo := VariantToPointer(V);

    if PropInfo <> nil then
    begin
      case PropInfo.PropType^^.Kind of
        tkInteger, tkChar, tkWChar:
          begin
            TypeData := GetTypeData(PropInfo^.PropType^);
            SetOrdProp(FOwner, PropInfo, RangedValue(TypeData^.MinValue, TypeData^.MaxValue));
          end;
        tkEnumeration:
          if VarType(Value) = varString then
            SetEnumProp(FOwner, PropInfo, VarToStr(Value))
          else
          begin
            TypeData := GetTypeData(PropInfo^.PropType^);
            SetOrdProp(FOwner, PropInfo, RangedValue(TypeData^.MinValue, TypeData^.MaxValue));
          end;
        tkSet:
          if VarType(Value) = varInteger then
            SetOrdProp(FOwner, PropInfo, Value)
          else
            SetSetProp(FOwner, PropInfo, VarToStr(Value));
        tkFloat:
          SetFloatProp(FOwner, PropInfo, Value);
        tkString, tkLString, tkWString:
          SetStrProp(FOwner, PropInfo, VarToStr(Value));
        tkVariant:
          SetVariantProp(FOwner, PropInfo, Value);
        tkInt64:
          begin
            TypeData := GetTypeData(PropInfo^.PropType^);
            SetInt64Prop(FOwner, PropInfo, RangedValue(TypeData^.MinInt64Value, TypeData^.MaxInt64Value));
          end;
      else
      end;
    end;
  end
  else
  begin
    k := FList.IndexOf(Format('Set%s', [DataField]));
    if k<>-1 then
    begin
      PProcedure := VariantToPointer(FList.Items[k]);
      PProcedure^(Value);
    end;
    FList.Add(DataField, Value);
  end;
end;

关于 Delphi跨平台开发Android调用 JNI JAR java 的说明和注意事项
Delphi开发局QQ群:32422310
12-06 3296
2Pascal-新时代的Pascal-关于 调用 JNI JAR java 的说明和注意事项，调用第 靠写不下了 - Powered by Discuz! 关于 调用 JNI JAR 的说明和注意事项，调用第三方 JAR SDK 和 翻译 安卓 JAVA 代码 的说明 V2017.10.18 (* ************************************************ *) (*　　　　　　　　　　　　　　　　　　　　　　　　　*) (*　　　　　　　　　　　　　　　　　　　　　
Delphi使用TStringHash实现建立类（有点像反射）
05-03
2.保证无毒 3.简单,方便,实用 4.实例可以自行改用 5.如有非法,本人无法律责任,由改动代码人负责！ 6.需要更多本人作品,查找标签“朱建强” 7.请下载,杀毒后再使用！
Delphi反射
diligentcat的专栏
10-26 2432
最近在写一个框架，需要用到反射，与C# java这些原生支持反射的语言不同，delphi对反射的支持相对要弱一些，但也够用了，其实C#的大部分的思想还是从 delphi而来，毕竟都是安德鲁斯的杰作。 这是只谈想法，不谈实现。Delphi7里其实就有对反射的支持了，typInfo,objAuto。基本上可以实现大部分的功能。但对静态方法的支持目前还没有好的解决办法。调用objectInvoke时
std::invoke详解
最新发布
漫步者
03-14 650
std::invoke表示函数调用：只要调用std::invoke，且执行了这个语句，那么就相当于调用了传入的函数对象std::invoke的含义传入一个函数对象及这个函数对象的参数，然后通过std::invoke完成这个函数的调用std::invoke可以实现对函数对象的调用，达到与直接调用函数相同的效果如果要实现类似回调系统、事件系统类似的功能，需要集合模板来实现。
delphi RTTI 反射技术
aldsot0997的博客
06-11 349
unit Unit_main; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, TypInfo; type TForm_main = class(TForm) Button1...
Delphi2010强化的反射
敦格
01-09 2743
Delphi2010强化的反射
delphi字符串调用类、方法（源码）
08-10
在Delphi编程环境中，字符串调用类和方法是常见的操作，尤其在动态代码执行和反射等高级编程场景中。Delphi作为一个强大的Object Pascal开发平台，提供了丰富的字符串处理和类方法调用机制。以下是对这个主题的详细...
Delphi反射机制与函数动态调用
本文旨在深入探讨Delphi反射机制及其在动态函数调用中的应用。首先概述Delphi反射机制，然后详细介绍其理论基础，包括类型信息的获取、结构和存储，以及元数据描述和动态类型检查。接着，文章讨论了Delphi函数的动态...
C#、VB与Delphi的跨语言反射工具使用体验
虽然通常Chrome DevTools用于前端开发调试，但其内置的JavaScript运行环境也可以利用JavaScript语言的反射能力，如使用`Object.getOwnPropertyNames`，`Function.prototype.toString`，`Reflect`对象等功能来在运行...
解决Delphi7数据执行保护
12-25
Delphi 7是一款经典的Object Pascal集成开发环境，用于创建Windows应用程序。在开发过程中，开发者可能会遇到一个问题：当尝试使用Delphi 7编译的程序调用WebService时，由于Windows的数据执行保护（DEP，Data ...
delphi dll静态调用 动态调用 实例
04-23
delphi dll静态调用 动态调用 实例delphi dll静态调用 动态调用 实例
Delphi2009 反射机制的使用
编程资料收集与共享交流
10-04 838
 Delphi2009中添加了一个用于实现反射的单元，即ObjAuto，用它可以轻松的实现反射。对于原本的RTTI，只能够得到published区分符下的属性，而反射机制则可以得到拥有反射支持的类的公开方法，成员变量和属性。下面是一个小例子：首先写一个拥有反射支持的类，注意类必须继承自TPersistent，并且类声明带有MethodInfo编译预处理。MethodInfo是一个全新的预处理指令，
DELPHI 反射机制
weixin_30737363的博客
08-18 465
CodeunitUnit1;interfaceusesWindows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,Buttons,ObjAuto;type{$MethodInfoON}TTestCall=class(TPersistent)...
delphi 反射 (转)
02-20 158
====================================================== 注：重要！程序员如何有效的放松身心！下班后做什么？ ====================================================== 关于反射的用途是『降低模块间的耦合度』这个倒未必尽然 单就delphi来说,从实现上看,它的所谓反射是基于rtti,
反射机制传递类_橙子的Delphi技术专区
quasiceo
12-26 904
鉴于某人说Delphi的反射不能传入或传出类，我在此纠正一下这个说法，下面的代码可以证实，类可以传入传出。 由于我已经把D2009的反射单元移去D2007，因此就不用D2009了，所以代码中暂时不考虑Unicode的问题。 unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Gr
反射 数据类型_Delphi反射机制初探
weixin_36209848的博客
01-12 543
在Java中存在着一种强大的功能就是反射，所以我在考虑Delphi出来这么多年了，难道没有支持反射机制吗？经过翻山越岭的一顿搜索终于找到了反射的身影在Delphi中反射称为RTTI(Run-Time Type Information) 翻译过来的名称是"运行期类型信息"，也就是说可以在运行期获得数据类型或类(class)的信息反射在我们普通程序开发中基本使用不到，但是在我们底层的程序设计中使用特别...
Delphi 2009 的反射单元(ObjAuto):
weixin_34362875的博客
09-26 146
为什么80%的码农都做不了架构师？>>> ...
新：Delphi 2009 的反射单元 (ObjAuto)
live的专栏
08-28 474
ObjAuto 单元应该算是对 TypInfo 单元的功能扩展吧? 它提供了 5 个方法:GetMethods、GetMethodInfo、CreateMethodPointer、ReleaseMethodPointer、ObjectInvoke通过 GetMethods、GetMethodInfo 可以获取类公用成员的详细信息.通过 TypInfo 只能获取 published 区中成员的信息
评论 1
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值