objautox.pas

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

    Result := cvt
  else
    Result := Codes[Source][Dest];
end;

function InterfaceDerivesFrom(TypeData: PTypeData; const GUID: TGUID): boolean;
begin
  Result := True;
  while TypeData <> nil do
  begin
    if IsEqualGUID(TypeData^.Guid, GUID) then
      Exit;
    if (TypeData^.IntfParent <> nil) and (TypeData^.IntfParent^ <> nil) then
      TypeData := GetTypeData(TypeData^.IntfParent^)
    else
      Break;
  end;
  Result := False;
end;

function GetVariantType(TypeInfo: PTypeInfo): TVarType;
var
  TypeData: PTypeData;
begin
  case TypeInfo^.Kind of
    tkUnknown: Result := varError;

    tkInteger, tkChar, tkEnumeration, tkWChar:
      if (TypeInfo = System.TypeInfo(boolean)) or (TypeInfo =
        System.TypeInfo(wordbool)) or (TypeInfo = System.TypeInfo(longbool)) then
        Result := varBoolean
      else
      begin
        TypeData := GetTypeData(TypeInfo);
        if TypeData^.MinValue >= 0 then
          if cardinal(TypeData^.MaxValue) > $FFFF then
            Result := varLongWord
          else if TypeData^.MaxValue > $FF then
            Result := varWord
          else
            Result := varByte
        else
        if (TypeData^.MaxValue > $7FFF) or (TypeData^.MinValue < -$7FFF - 1) then
          Result := varInteger
        else if (TypeData^.MaxValue > $7F) or (TypeData^.MinValue < -$7F - 1) then
          Result := varSmallint
        else
          Result := varShortint;
      end;
    tkFloat:
    begin
      TypeData := GetTypeData(TypeInfo);
      case TypeData^.FloatType of
        ftSingle: Result := varSingle;
        ftDouble:
          if TypeInfo = System.TypeInfo(TDateTime) then
            Result := varDate
          else
            Result := varDouble;
        ftComp, ftCurr: Result := varCurrency;
        else
          Result := varError;
      end;
    end;
    tkString: Result  := varString;
    tkLString: Result := varString;
  {$IFDEF DELPHI2009}
    tkUString: Result := varUString;
  {$ENDIF}
    tkWString: Result := varOleStr;
    tkInterface:
    begin
      TypeData := GetTypeData(TypeInfo);
      if InterfaceDerivesFrom(TypeData, IDispatch) then
        Result := varDispatch
      else
        Result := varUnknown;
    end;
    tkVariant: Result := varVariant;
    tkInt64:
  {$IFDEF DELPHI2009}
    begin
      TypeData := GetTypeData(TypeInfo);
      if TypeData^.MinInt64Value >= 0 then
        Result := varUInt64
      else
        Result := varInt64;
    end;
  {$ELSE}
		Result   := varInt64;
	{$ENDIF}

    tkClass: Result := varInteger;

    else
      Result := varError;
  end;
end;

procedure GetFloatReturn(var Ret; FloatType: TFloatType);
asm
  CMP     EDX, ftSingle
  JE      @@single
  CMP     EDX, ftDouble
  JE      @@double
  CMP     EDX, ftExtended
  JE      @@extended
  CMP     EDX, ftCurr
  JE      @@Curr
  CMP     EDX, ftComp
  JE      @@Curr    // Same as Curr
  // should never get here
  @@single:
  FSTP      DWORD PTR [EAX]
  WAIT
  RET
  @@double:
  FSTP      QWORD PTR [EAX]
  WAIT
  RET
  @@extended:
  FSTP      TBYTE PTR [EAX]
  WAIT
  RET
  @@Curr:
  FISTP     QWORD PTR [EAX]
  WAIT
end;

function GetMethods(ClassType: TClass): TMethodInfoArray;
var
  VMT:        Pointer;
  MethodInfo: Pointer;
  Count:      integer;
  I:          integer;
begin
  Count := 0;
  VMT   := ClassType;
  repeat
    MethodInfo := PPointer(integer(VMT) + vmtMethodTable)^;
    if MethodInfo <> nil then
      Inc(Count, PWord(MethodInfo)^);
    // Find the parent VMT
    VMT := PPointer(integer(VMT) + vmtParent)^;
    if VMT = nil then
      Break;
    VMT := PPointer(VMT)^;
  until False;
  SetLength(Result, Count);
  I   := 0;
  VMT := ClassType;
  repeat
    MethodInfo := PPointer(integer(VMT) + vmtMethodTable)^;
    if MethodInfo <> nil then
    begin
      Count := PWord(MethodInfo)^;
      Inc(integer(MethodInfo), SizeOf(word));
      while Count > 0 do
      begin
        Result[I] := MethodInfo;
        Inc(I);
        Inc(integer(MethodInfo), PMethodInfoHeader(MethodInfo)^.Len);
        Dec(Count);
      end;
    end;
    // Find the parent VMT
    VMT := PPointer(integer(VMT) + vmtParent)^;
    if VMT = nil then
      Exit;
    VMT := PPointer(VMT)^;
  until False;
end;

function GetMethodInfo(Instance: TObject;
  const MethodName: ShortString): PMethodInfoHeader;
var
  VMT:        Pointer;
  MethodInfo: Pointer;
  Count:      integer;
begin
  // Find the method
  VMT := PPointer(Instance)^;
  repeat
    MethodInfo := PPointer(integer(VMT) + vmtMethodTable)^;
    if MethodInfo <> nil then
    begin
      // Scan method table for the method
      Count := PWord(MethodInfo)^;
      Inc(integer(MethodInfo), 2);
      while Count > 0 do
      begin
        Result := MethodInfo;
        if
{$IFDEF DELPHI2009}
        SamePropTypeName
{$ELSE}SameText{$ENDIF}
          (Result^.Name, MethodName) then
          Exit;
        Inc(integer(MethodInfo), PMethodInfoHeader(MethodInfo)^.Len);
        Dec(Count);
      end;
    end;
    // Find the parent VMT
    VMT := PPointer(integer(VMT) + vmtParent)^;
    if VMT = nil then
    begin
      Result := nil;
      Exit;
    end;

    VMT := PPointer(VMT)^;
  until False;
end;

resourcestring
  sMethodNotFound = 'Method %s of class %s not found';
  sTypeMisMatch   = 'Type mismatch in parameter %d for method %s';
  sInvalidDispID  = 'Invalid DispID for parameter %d in method %s';
  sParamRequired  = 'Parameter %d required for method %s';
  sMethodOver     = 'Method definition for %s has over %d parameters';
  sTooManyParams  = 'Too many parameters for method %s';

 /// ObjectInvoke - function to dymically invoke a method of an object that
 /// has sufficient type information.
 ///   Instance -      the object to invoke the method on
 ///   MethodHeader -  the type information for the method obtained through
 ///                   GetMethodInfo.
 ///   ParamIndexs -   the indexs of the parameters. This assumes that the
 ///                   indexs are 1 offset. The number of indexs do not need
 ///                   to match the number of parameters. The parameters left
 ///                   over are assumed to fill in the holes left by indexs.
 ///                   Param indexs are assumed to be in lexical order, not
 ///                   inverse lexical order like Params.
 ///   Params -        the parameters for the function invocation. The
 ///                   order of the parameters is assumed to be in inverse
 ///                   lexical order, last parameter first.

function ObjectInvoke(Instance: TObject; MethodHeader: PMethodInfoHeader;
  const ParamIndexes: array of integer; const Params: array of variant): variant;
const
  MaxParams = 32;

  procedure Swap(var A, B: PParamInfo);
  var
    T: PParamInfo;
  begin
    T := A;
    A := B;
    B := T;
  end;

var
  MethodName: string;

  procedure ParameterMismatch(I: integer);
  begin
    raise Exception.CreateFmt(sTypeMisMatch, [I, MethodName]);
  end;

var
  MethodInfo: Pointer;
  ReturnInfo: PReturnInfo;
  MethodAddr: Pointer;
  InfoEnd:  Pointer;
  Count:    integer;
  I, K, P:  integer;
  Param:    PParamInfo;
  Regs:     array[paEAX..paECX] of cardinal;
  RetVal:   variant;
  ParamType: TVarType;
  VarType:  TVarType;
  ParamVarData: PVarData;
  PushData: Pointer;
  ParamBytes: integer;
  Size:     integer;
  Frame:
{$IFDEF DELPHI2009}
            PByte
{$ELSE}PChar{$ENDIF}
  ;
  ResultParam: Pointer;
  ResultPointer: Pointer;
  ParamInfos: array[0..MaxParams - 1] of PParamInfo;
  ParamData: array[0..MaxParams - 1] of Pointer;
  Pointers: array[0..MaxParams - 1] of Pointer;
  Temps:    array[0..MaxParams - 1] of variant;
begin
  // MethodInfo now points to the method we found.
  MethodInfo := MethodHeader;
  MethodAddr := MethodHeader^.Addr;
  MethodName :=
{$IFDEF DELPHI2009}
    UTF8ToString(
{$ENDIF}
    PMethodInfoHeader(MethodInfo)^.Name
{$IFDEF DELPHI2009}
    )
{$ENDIF}
  ;
  Inc(integer(MethodInfo), SizeOf(TMethodInfoHeader) - SizeOf(ShortString) +
    1 + Length(MethodName));
  ReturnInfo := MethodInfo;
  Inc(integer(MethodInfo), SizeOf(TReturnInfo));

  InfoEnd := Pointer(integer(MethodHeader) + MethodHeader^.Len);
  Count   := 0;
  while integer(MethodInfo) < integer(InfoEnd) do
  begin
    if Count >= MaxParams then
      raise Exception.CreateFmt(sMethodOver, [MethodName, MaxParams]);
    ParamInfos[Count] := MethodInfo;
    Inc(Count);
    Inc(integer(MethodInfo), SizeOf(TParamInfo) - SizeOf(ShortString) + 1 +
      Length(PParamInfo(MethodInfo)^.Name));
  end;

  if High(Params) >= Count then
    raise Exception.CreateFmt(sTooManyParams, [MethodName]);

  // Fill the ParamData array, converting the type as necessary, taking
  // into account any ParamIndexes supplied
  P := 0;
  FillChar(ParamData, SizeOf(ParamData), 0);
  for I := 0 to High(Params) do
  begin
    // Figure out what parameter index this parameter refers to.
    // If it is a named parameter it will have an entry in the ParamIndexs
    // array. If not, P points to the current parameter to use for unnamed
    // parameters. K is the formal parameter number.
    // This calculation assumes Self is first and any result parameters are last
    if I <= High(ParamIndexes) then
    begin
      K := ParamIndexes[I];
      if K >= Count then
        raise Exception.CreateFmt(sInvalidDispID, [I, MethodName]);
    end
    else
      K := High(Params) - P + 1;  // Add one to account for Self
    Param := ParamInfos[K];
    ParamType    := GetVariantType(Param^.ParamType^);
    ParamVarData := @Params[I];
    VarType      := ParamVarData^.VType;
    if Param^.Flags * [pfOut, pfVar] <> [] then
    begin

      // For pfVar, the variant must be a byref and equal to the type.
      if (VarType <> ParamType or varByRef) and (ParamType <> varVariant) then
        ParameterMismatch(I);
    end
    else
      // Convert the parameter to the right type
      case ConvertKindOf(VarType and varTypeMask, ParamType) of
        ckConvert:
          try
            Temps[I] := VarAsType(Params[I], ParamType);
            // The data bytes for sizes < 4 are dirty, that is they are not
            // guarenteed to have 0's in the high bytes. We need them to be zero'ed
            if ParamType <= CMaxArrayVarType then
              case CVarTypeToElementInfo[ParamType].Size of
                1: TVarData(Temps[I]).VLongWord := TVarData(Temps[I]).VByte;
                2: TVarData(Temps[I]).VLongWord := TVarData(Temps[I]).VWord;
              end;
            ParamVarData := @Temps[I];
          except
            ParameterMismatch(I);
          end;
        ckError: ParameterMismatch(I);
      end;

    if ParamType = varVariant then
    begin
      Pointers[K]  := ParamVarData;
      ParamData[K] := @Pointers[K];
    end
    else if varByRef and VarType <> 0 then
      ParamData[K] := @ParamVarData^.VPointer
    else
      ParamData[K] := @ParamVarData^.VInteger;

    // Update P which is the pointer to the current non-named parameter.
    // This assumes that unnamed parameter fill in the holes left by
    // named parameters.
    while (P <= High(Params)) and (ParamData[High(Params) - P + 1] <> nil) do
      Inc(P);
  end;

  // Set up the call frame        RET EBP
  ParamBytes := ReturnInfo^.ParamSize - (4 + 4);
  asm
    SUB     ESP,ParamBytes
    MOV     Frame,ESP
  end;
  Dec(integer(Frame), 4 + 4); // Access numbers include RET and EBP

  // Push the parameters on the stack (or put them into the correct register)
  ResultParam := nil;
  for I := 0 to Count - 1 do
  begin
    Param    := ParamInfos[I];
    PushData := ParamData[I];
    if PushData = nil then
      if (Param^.ParamType^.Kind = tkClass) and
{$IFDEF DELPHI2009}
        SamePropTypeName
{$ELSE}SameText{$ENDIF}
        (Param^.Name, 'SELF') then
        // Self is special. It doesn't appear in the ParamData array since it
        // is not represented in the Params array.
        PushData := @Instance
      else if pfResult in Param^.Flags then
      begin
        ResultParam := Param;
        VarClear(Result);
        TVarData(Result).VType := GetVariantType(Param^.ParamType^);
        if TVarData(Result).VType = varVariant then
          ResultPointer := @Result
        else
          ResultPointer := @TVarData(Result).VInteger;