📄 objautox.pas

📁 在delphi下实现类似于java, C#等反射调用的一个例子
💻 PAS
📖 第 1 页 / 共 3 页
字号:
12 3 下一页
 {*******************************************************}
 {           CodeGear Delphi Runtime Library             }
 {               Delphi Reflection Unit                  }
 {                Work likes Java & C#                   }
 {              Copyright(c) 2008 Rarnu                  }
 {*******************************************************}

unit ObjAutoX;

interface

uses TypInfo;

{$IFDEF VER130}
  Not Support Delphi 5
{$ENDIF}
{$IFDEF VER120}
  Not Support Delphi 4
{$ENDIF}
{$IFDEF VER100}
  Not Support Delphi 3
{$ENDIF}
{$IFDEF VER90}
  Not Support Delphi 2
{$ENDIF}
{$IFDEF VER80}
  Not Support Delphi 1
{$ENDIF}

{$IFDEF VER200}
  {$DEFINE DELPHI2009}
{$ENDIF}

const
  paEAX     = word(0);
  paEDX     = word(1);
  paECX     = word(2);
  paStack   = word(3);
  SHORT_LEN = SizeOf(ShortString) - 1;

type
  TCallingConvention = (ccRegister, ccCdecl, ccPascal, ccStdCall, ccSafeCall);
  TParamFlags        = set of (pfVar, pfConst, pfArray, pfAddress, pfReference, pfOut,
    pfResult);
  PPointer           = ^Pointer;
  PWord              = ^word;
  PMethodInfoHeader  = ^TMethodInfoHeader;

  TMethodInfoHeader = packed record
    Len:  word;
    Addr: Pointer;
    Name: ShortString;
  end;

  PPropertyInfo = PPropInfo;

  PReturnInfo = ^TReturnInfo;

  TReturnInfo = packed record
    Version:           byte; // Must be 1
    CallingConvention: TCallingConvention;
    ReturnType:        ^PTypeInfo;
    ParamSize:         word;
  end;

  PParamInfo = ^TParamInfo;

  TParamInfo = packed record
    Flags:     TParamFlags;
    ParamType: ^PTypeInfo;
    Access:    word;
    Name:      ShortString;
  end;
  TMethodInfoArray = array of PMethodInfoHeader;
  TParamInfoArray  = array of PParamInfo;
  TPropertyArray   = array of PPropertyInfo;

 // 动态调用方法
 // 参数：
 // Instance: 类实例
 // MethodHeader: 类内方法 $MethodInfo 信息
 // ParamIndexes: 参数索引
 // Params: 参数表
 // Return: 被调用方法的返回值
function ObjectInvoke(Instance: TObject; MethodHeader: PMethodInfoHeader;
  const ParamIndexes: array of integer; const Params: array of variant): variant;

 // 获取方法 $MethodInfo 信息
 // 参数：
 // Instance: 类实例
 // MethodName: 方法名
 // Return: 类内方法 $MethodInfo 信息
function GetMethodInfo(Instance: TObject;
  const MethodName: ShortString): PMethodInfoHeader;

type
  IMethodHandler = interface
    ['{4E61C8CD-16CC-4830-B1E4-84F86FBC0D23}']
    function Execute(const Args: array of variant): variant;
    function InstanceToVariant(Instance: TObject): variant;
  end;

  PParameters = ^TParameters;

  TParameters = packed record
    Registers: array[paEDX..paECX] of cardinal;
    Stack:     array[0..1023] of byte;
  end;
  TDynamicInvokeEvent = procedure(Params: PParameters; StackSize: integer) of object;

 // 建立代码委托智能指针(重载)
 // 参数：
 // MethodHandler: 方法句柄接口
 // TypeData: 方法 $TypeData 信息
 // Return: 方法指针
function CreateMethodPointer(const MethodHandler: IMethodHandler;
  TypeData: PTypeData): TMethod; overload;

 // 建立代码委托智能指针(重载)
 // 参数：
 // ADynamicInvokeEvent: 方法调用事件函数对象
 // TypeData: 方法 $TypeData 信息
 // Return: 方法指针
function CreateMethodPointer(const ADynamicInvokeEvent: TDynamicInvokeEvent;
  TypeData: PTypeData): TMethod; overload;

 // 释放代码委托智能指针
 // 参数：
 // Method: 方法指针
procedure ReleaseMethodPointer(MethodPointer: TMethod);

 // 获取方法列表
 // 参数：
 // ClassType: 类TypeInfo信息
 // Return: 类内方法 $MethodInfo 列表
function GetMethods(ClassType: TClass): TMethodInfoArray;
function GetInvokeInstance(MethodPointer: TMethod): TObject;

 // 获取参数列表
 // 参数：
 // Instance: 类实例
 // MethodName: 方法名
 // Return: 类内方法参数 $MethodInfo 列表
function GetParams(Instance: TObject; MethodName: string): TParamInfoArray;

 // 获取返回值信息
 // 参数：
 // Instance: 类实例
 // MethodName: 方法名
 // Return: 类内方法返回值 $MethodInfo 信息
function GetReturnInfo(Instance: TObject; MethodName: string): PReturnInfo;

// 获取属性列表
// 参数：
// ClassType: 类TypeInfo信息
// Return: 类内公开属性 $M 列表
function GetProperties(ClassType: TClass): TPropertyArray;

implementation

uses SysUtils, Variants, VarUtils, RTLConsts;

function GetProperties(ClassType: TClass): TPropertyArray;
var
  ClassTypeInfo: PTypeInfo;
  ClassDataInfo: PTypeData;
  Pplst: PPropList;
  i: integer;
begin
  ClassTypeInfo := ClassType.ClassInfo;
  ClassDataInfo := GetTypeData(ClassTypeInfo);
  if ClassDataInfo.PropCount <> 0 then
  begin
    GetMem(Pplst, sizeof(PPropInfo) * ClassDataInfo.PropCount);
    try
      GetPropInfos(ClassTypeInfo, Pplst);
      SetLength(Result, ClassDataInfo.PropCount);
      for i := 0 to ClassDataInfo.PropCount - 1 do
      begin
        Result[i] := Pplst[i];
      end;
    finally
      FreeMem(Pplst, sizeof(PPropInfo) * ClassDataInfo.PropCount);
    end;
  end;
end;

function GetTypeSize(TypeInfo: PTypeInfo): integer;
var
  TypeData: PTypeData;
begin
  case TypeInfo^.Kind of
    tkInteger, tkEnumeration:
    begin
      TypeData := GetTypeData(TypeInfo);
      if TypeData^.MinValue >= 0 then
        if cardinal(TypeData^.MaxValue) > $FFFF then
          Result := 4
        else if TypeData^.MaxValue > $FF then
          Result := 2
        else
          Result := 1
      else
      if (TypeData^.MaxValue > $7FFF) or (TypeData^.MinValue < -$7FFF - 1) then
        Result := 4
      else if (TypeData^.MaxValue > $7F) or (TypeData^.MinValue < -$7F - 1) then
        Result := 2
      else
        Result := 1;
    end;
    tkFloat:
    begin
      TypeData := GetTypeData(TypeInfo);
      case TypeData^.FloatType of
        ftSingle: Result := 4;
        ftComp, ftCurr, ftDouble: Result := 8;
        else
          Result := -1;
      end;
    end;
    tkString, tkLString,
{$IFDEF DELPHI2009}
    tkUString,
{$ENDIF}
    tkWString, tkInterface, tkClass:
      Result := 4;
    tkMethod, tkInt64:
      Result := 8;
    tkVariant:
      Result := 16;
    else
      Assert(False);
      Result := -1;
  end;
end;

type
  TConvertKind = (ckNone, ckConvert, ckError);

function ConvertKindOf(Source, Dest: TVarType): TConvertKind;
const
  none = ckNone;
  cvt  = ckConvert;
  err  = ckError;
  Codes: array[varEmpty..
{$IFDEF DELPHI2009}
    varUInt64
{$ELSE}varInt64{$ENDIF}
    , varEmpty..
{$IFDEF DELPHI2009}
    varUInt64
{$ELSE}varInt64{$ENDIF}
    ] of TConvertKind =
    ({v From} {To >}{vt_empty} {vt_null} {vt_i2} {vt_i4} {vt_r4}
    {vt_r8}{vt_cy}{vt_date}{vt_bstr}{vt_dispatch}{vt_error}{vt_bool}
    {vt_variant}{vt_unknown}{vt_decimal}{0x0f }{vt_i1}{vt_ui1}
    {vt_ui2}{vt_ui4}{vt_i8}{vt_ui8}
    {vt_empty}      (none, err, err, err, err, err,
    err, err, err, err, err, err, none,
    err, err, err, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_null}       (err, none, err, err, err, err,
    err, err, err, err, err, err, none,
    err, err, err, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_i2}         (err, err, none, cvt, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_i4}         (err, err, none, none, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_r4}         (err, err, cvt, cvt, none, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_r8}         (err, err, cvt, cvt, cvt, none,
    none, none, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_cy}         (err, err, cvt, cvt, cvt, none,
    none, none, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_date}       (err, err, cvt, cvt, cvt, none,
    none, none, cvt, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_bstr}       (err, err, cvt, cvt, cvt, cvt,
    cvt, cvt, none, err, err, cvt, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_dispatch}   (err, err, err, err, err, err,
    err, err, err, none, err, err, none,
    none, err, err, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_error}      (err, err, err, err, err, err,
    err, err, err, err, none, err, none,
    err, err, err, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_bool}       (err, err, cvt, cvt, err, err,
    err, err, cvt, err, err, none, none,
    err, cvt, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_variant}    (cvt, cvt, cvt, cvt, cvt, cvt,
    cvt, cvt, cvt, cvt, cvt, cvt, none,
    cvt, cvt, cvt, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_unknown}    (err, err, err, err, err, err,
    err, err, err, err, err, err, none,
    none, err, err, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_decimal}    (err, err, cvt, cvt, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, none, err, cvt, cvt, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {0x0f }         (err, err, err, err, err, err,
    err, err, err, err, err, err, none,
    err, err, none, err, err, err, err, err
{$IFDEF DELPHI2009}
    , err
{$ENDIF}
    ),
    {vt_i1}         (err, err, cvt, cvt, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_ui1}        (err, err, cvt, cvt, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, cvt, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_ui2}        (err, err, none, cvt, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, none, cvt, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_ui4}        (err, err, none, none, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, none, none, cvt
{$IFDEF DELPHI2009}
    , cvt
{$ENDIF}
    ),
    {vt_i8}         (err, err, none, none, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, none, none, none
{$IFDEF DELPHI2009}
    , none
{$ENDIF}
    )
{$IFDEF DELPHI2009}
    {vt_ui8}, (err, err, none, none, cvt, cvt,
    cvt, cvt, cvt, err, err, cvt, none,
    err, cvt, err, none, none, none,
    none, none, none)
{$ENDIF}
    );
begin
  if Source = Dest then
    Result := none
  else
  // < Low(Codes) always evaluates to false since it is zero
  if {(Source < Low(Codes)) or} (Source > High(Codes)) or
    {(Dest < Low(Codes)) or} (Dest > High(Codes)) then
12 3 下一页
💿 文件大小 205 K
👤 上传用户 qq448792326
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#delphi #java #反射
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -