objautox.pas

在delphi下实现类似于java, C#等反射调用的一个例子

        PushData := @ResultPointer;
      end
      else
        raise Exception.CreateFmt(sParamRequired, [I, MethodName]);
    if Param^.Access < word(Ord(paStack)) then
      Regs[Param^.Access] := PCardinal(PushData)^
    else
    begin
      if [pfVar, pfOut, pfResult] * Param^.Flags <> [] then
        PCardinal(@Frame[Param^.Access])^ := PCardinal(PushData)^
      else
      begin
        Size := GetTypeSize(Param^.ParamType^);
        case Size of
          1, 2, 4:
            PCardinal(@Frame[Param^.Access])^ := PCardinal(PushData)^;
          8:
          begin
            PCardinal(@Frame[Param^.Access])^     := PCardinal(PushData)^;
            PCardinal(@Frame[Param^.Access + 4])^ :=
              PCardinal(integer(PushData) + 4)^;
          end;
          else
            Move(PushData^, Frame[Param^.Access and not 3], Size);
        end;
      end;
    end;
  end;

  // Do the call
  asm
    MOV     EAX,DWORD PTR Regs[0]
    MOV     EDX,DWORD PTR Regs[4]
    MOV     ECX,DWORD PTR Regs[8]
    CALL    MethodAddr
    MOV     DWORD PTR Regs[0],EAX
    MOV     DWORD PTR Regs[4],EDX
  end;

  if ReturnInfo^.CallingConvention = ccCdecl then
    asm
      ADD     ESP,ParamBytes
    end;

  if (ResultParam = nil) and (ReturnInfo^.ReturnType <> nil) then
  begin
    // The result came back in registers. Otherwise a result pointer was used
    // and the return variant is already initialized (or it was a procedure)
    TVarData(RetVal).VType := GetVariantType(ReturnInfo^.ReturnType^);
    if ReturnInfo^.ReturnType^.Kind = tkFloat then
      GetFloatReturn(TVarData(RetVal).VDouble,
        GetTypeData(ReturnInfo^.ReturnType^)^.FloatType)
    else
    begin
      // For regular Boolean types, we must convert it to a boolean to
      // wipe the high order bytes; otherwise the caller may see a false
      // as true.
      if (TVarData(RetVal).VType = varBoolean) and
        (ReturnInfo^.ReturnType^ = System.TypeInfo(boolean)) then
        TVarData(RetVal).VInteger := integer(boolean(Regs[paEAX]))
      else
        TVarData(RetVal).VInteger := integer(Regs[paEAX]);
      PCardinal(integer(@TVarData(RetVal).VInteger) + 4)^ := Regs[paEDX];
    end;
    Result := RetVal;
    TVarData(RetVal).VType := varEmpty;
  end;
end;

function GetReturnInfo(Instance: TObject; MethodName: string): PReturnInfo;
var
  mi: PMethodInfoHeader;
begin
  mi := GetMethodInfo(Instance, ShortString(MethodName));
  if mi.Len <= SizeOf(TMethodInfoHeader) + Length(mi.Name) - SHORT_LEN then
  begin
    Result := nil;
    Exit;
  end;
  Result := PReturnInfo(integer(mi) + SizeOf(TMethodInfoHeader) +
    Length(mi.Name) - SHORT_LEN);
end;

function GetParams(Instance: TObject; MethodName: string): TParamInfoArray;
var
  mi:    PMethodInfoHeader;
  miEnd: Pointer;
  param: PParamInfo;
  Count: integer;
begin
  SetLength(Result, 0);
  mi := GetMethodInfo(Instance, ShortString(MethodName));
  if mi.Len <= SizeOf(TMethodInfoHeader) + Length(mi.Name) - SHORT_LEN then
    Exit;
  miEnd := Pointer(integer(mi) + mi.Len);
  param := PParamInfo(integer(mi) + SizeOf(TMethodInfoHeader) +
    Length(mi.Name) - SHORT_LEN + SizeOf(TReturnInfo));
  Count := 0;
  while integer(param) < integer(miEnd) do
  begin
    Inc(Count);
    SetLength(Result, Count);
    Result[Count - 1] := param;
    param := PParamInfo(integer(param) + SizeOf(TParamInfo) +
      Length(param.Name) - SHORT_LEN);
  end;
end;

type
  PParameterInfos = ^TParameterInfos;
  TParameterInfos = array[0..255] of ^PTypeInfo;

  TBaseMethodHandlerInstance = class
  protected
    TypeData:     PTypeData;
    ParamInfos:   PParameterInfos;
    ParamOffsets: array of word;
    StackSize:    integer;
    procedure InternalHandler(Params: Pointer);
    procedure Handler(Params: Pointer); virtual; abstract;
    procedure RegisterStub;
  public
    constructor Create(TypeData: PTypeData);
  end;

  TMethodHandlerInstance = class(TBaseMethodHandlerInstance)
  protected
    MethodHandler: IMethodHandler;
    procedure Handler(Params: Pointer); override;
  public
    constructor Create(const MethodHandler: IMethodHandler; TypeData: PTypeData);
  end;

  TEventHandlerInstance = class(TBaseMethodHandlerInstance)
  protected
    FDynamicInvokeEvent: TDynamicInvokeEvent;
    procedure Handler(Params: Pointer); override;
  public
    constructor Create(const ADynamicInvokeEvent: TDynamicInvokeEvent;
      TypeData: PTypeData);
  end;

function AdditionalInfoOf(TypeData: PTypeData): Pointer;
var
  P:
{$IFDEF DELPHI2009}
     PByte
{$ELSE}PChar{$ENDIF}
  ;
  I: integer;
begin
  P := @TypeData^.ParamList;
  // Skip parameter names and types
  for I := 1 to TypeData^.ParamCount do
  begin
    Inc(P, 1 +
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[1]) + 1);
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1);
  end;
  if TypeData^.MethodKind = mkFunction then
    // Skip return type name and info
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1 + 4);
  Result := P;
end;

function CreateMethodPointer(const MethodHandler: IMethodHandler;
  TypeData: PTypeData): TMethod;
begin
  Result.Data := TMethodHandlerInstance.Create(MethodHandler, TypeData);
  Result.Code := @TMethodHandlerInstance.RegisterStub;
end;

function CreateMethodPointer(const ADynamicInvokeEvent: TDynamicInvokeEvent;
  TypeData: PTypeData): TMethod; overload;
begin
  Result.Data := TEventHandlerInstance.Create(ADynamicInvokeEvent, TypeData);
  Result.Code := @TMethodHandlerInstance.RegisterStub;
end;

procedure ReleaseMethodPointer(MethodPointer: TMethod);
begin
  TObject(MethodPointer.Data).Free;
end;

function GetInvokeInstance(MethodPointer: TMethod): TObject;
begin
  if TObject(MethodPointer.Data) is TEventHandlerInstance then
    Result := TObject(TMethod(TEventHandlerInstance(
      MethodPointer.Data).FDynamicInvokeEvent).Data)
  else
    Result := nil;
end;

{ TBaseMethodHandlerInstance }

constructor TBaseMethodHandlerInstance.Create(TypeData: PTypeData);
var
  P:
{$IFDEF DELPHI2009}
          PByte
{$ELSE}PChar{$ENDIF}
  ;
  Offset: integer;
  CurReg: integer;
  I:      integer;
  Size:   integer;
begin
  Self.TypeData := TypeData;

  P          := AdditionalInfoOf(TypeData);
  ParamInfos := PParameterInfos(cardinal(P) + 1);

  // Calculate stack size
  CurReg    := paEDX;
  P         := @TypeData^.ParamList;
  StackSize := 0;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    if TParamFlags(P[0]) * [pfVar, pfConst, pfAddress, pfReference, pfOut] <> [] then
      Size := 4
    else
      Size := GetTypeSize(ParamInfos^[I]^);
    if (Size <= 4) and (CurReg <= paECX) then
      Inc(CurReg)
    else
      Inc(StackSize, Size);
    Inc(P, 1 +
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[1]) + 1);
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1);
  end;

  // Calculate parameter offsets
  SetLength(ParamOffsets, TypeData^.PropCount);
  CurReg := paEDX;
  P      := @TypeData^.ParamList;
  Offset := StackSize;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    if TParamFlags(P[0]) * [pfVar, pfConst, pfAddress, pfReference, pfOut] <> [] then
      Size := 4
    else
      Size := GetTypeSize(ParamInfos^[I]^);
    if (Size <= 4) and (CurReg <= paECX) then
    begin
      ParamOffsets[I] := CurReg;
      Inc(CurReg);
    end
    else
    begin
      Dec(Offset, Size);
      ParamOffsets[I] := Offset;
    end;
    Inc(P, 1 +
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[1]) + 1);
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1);
  end;
end;

procedure TBaseMethodHandlerInstance.InternalHandler(Params: Pointer);
asm
  MOV     ECX,[EAX]
  JMP     DWORD PTR [ECX] + VMTOFFSET TMethodHandlerInstance.Handler
end;

procedure TBaseMethodHandlerInstance.RegisterStub;
const
  PtrSize = SizeOf(Pointer);
asm
  PUSH    EAX
  PUSH    ECX
  PUSH    EDX
  MOV     EDX,ESP
  CALL    InternalHandler
  // Pop EDX and ECX off the stack while preserving all registers.
  MOV[ESP+4],EAX
  POP     EAX
  POP     EAX
  POP     ECX    // Self
  MOV     ECX,[ECX].TMethodHandlerInstance.StackSize
  TEST    ECX,ECX
  JZ      @@SimpleRet
  // Jump to the actual return instruction since it is most likely not just a RET
  //JMP     ECX    // Data Exec. Prevention: Jumping into a GetMem allocated memory block

  // stack address alignment
  ADD     ECX, PtrSize - 1
  and     ECX, not (PtrSize - 1)
  and     ECX, $FFFF

  // clean up the stack
  PUSH    EAX                         // we need this register, so save it
  MOV     EAX,[ESP + 4]               // Load the return address
  MOV[ESP + ECX + 4], EAX        // Just blast it over the first param on the stack
  POP     EAX
  ADD     ESP,ECX                     // This will move the stack back to where the moved
  // return address is now located. The next RET
  // instruction will do the final stack cleanup
  @@SimpleRet:
end;

{ TMethodHandlerInstance }

constructor TMethodHandlerInstance.Create(const MethodHandler: IMethodHandler;
  TypeData: PTypeData);
begin
  inherited Create(TypeData);
  Self.MethodHandler := MethodHandler;
end;

procedure TMethodHandlerInstance.Handler(Params: Pointer);
const
  MaxParams = 10;
var
  P:
{$IFDEF DELPHI2009}
          PByte
{$ELSE}PChar{$ENDIF}
  ;
  Parameters: PParameters;
  ReturnValue: variant;
  ParamValues: array[0..MaxParams - 1] of variant;
  I:      integer;
  Regs:   array[paEAX..paEDX] of cardinal;
  Offset: integer;
  Data:   Pointer;
  Temp:   variant;
begin
  Parameters := Params;

  // Fetch the parameters into ParamValues
  P := @TypeData^.ParamList;
  for I := 0 to TypeData^.ParamCount - 1 do
  begin
    Offset := ParamOffsets[I];
    if (Offset >= paEDX) and (Offset <= paECX) then
      Data := @Parameters^.Registers[Offset]
    else
      Data := @Parameters^.Stack[Offset];
    if ParamInfos^[I]^.Kind = tkClass then
      ParamValues[TypeData^.ParamCount - I - 1] :=
        MethodHandler.InstanceToVariant(PPointer(Data)^)
    else if TParamFlags(P[0]) * [pfVar, pfOut] <> [] then
      with TVarData(ParamValues[TypeData^.ParamCount - I - 1]) do
      begin
        VType    := GetVariantType(ParamInfos[I]^) or varByRef;
        VPointer := Pointer(PCardinal(Data)^);
      end
    else
    begin
      TVarData(Temp).VType := GetVariantType(ParamInfos[I]^) or varByRef;
      if TParamFlags(P[0]) * [pfVar, pfOut] <> [] then
        TVarData(Temp).VPointer := Pointer(PCardinal(Data)^)
      else
        TVarData(Temp).VPointer := Data;
      ParamValues[TypeData^.ParamCount - I - 1] := Temp;
    end;
    Inc(P, 1 +
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[1]) + 1);
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1);
  end;
  // P is left pointing to the return type name if there is one.

  ReturnValue := MethodHandler.Execute(Slice(ParamValues, TypeData^.ParamCount));
  if TypeData^.MethodKind = mkFunction then
  begin
    Inc(P,
{$IFNDEF DELPHI2009}Byte{$ENDIF}
      (P[0]) + 1);
    ReturnValue := VarAsType(ReturnValue, GetVariantType(PPTypeInfo(P)^));
    if PPTypeInfo(P)^.Kind = tkFloat then

    else
    begin
      Regs[paEAX] := TVarData(ReturnValue).VLongWord;
      Regs[paEDX] := PCardinal(integer(@TVarData(ReturnValue).VLongWord) + 4)^;
    end;
  end;

  // Let Stub procedures know where the RET instruction is
  asm
    MOV     EAX,DWORD PTR Regs[paEAX*4]
    MOV     EDX,DWORD PTR Regs[paEDX*4]
  end;
end;

{ TEventHandlerInstance }

constructor TEventHandlerInstance.Create(const ADynamicInvokeEvent: TDynamicInvokeEvent;
  TypeData: PTypeData);
begin
  inherited Create(TypeData);
  Self.FDynamicInvokeEvent := ADynamicInvokeEvent;
end;

procedure TEventHandlerInstance.Handler(Params: Pointer);
begin
  if Assigned(FDynamicInvokeEvent) then
    FDynamicInvokeEvent(Params, StackSize);
end;

end.