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

关注

原创最新推荐文章于 2026-02-23 00:27:17 发布 3.6k 阅读 AI 写同款· GEO 优化 ›

Delphi通过JNI调用Java类完整实战项目 Spring Boot打包的jar用了特殊的，直接FindClass是找不到的。得用反射：varbegin// 获取当前线程'));// 获取上下文类加载器'));// 反射调用loadClass');end; 阅读详情

有的时候你会希望自己定义的一个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;