2007年12月 Delphi大版内专家分月排行榜第二2007年10月 Delphi大版内专家分月排行榜第二2007年9月 Delphi大版内专家分月排行榜第二2007年7月 Delphi大版内专家分月排行榜第二
2007年11月 Delphi大版内专家分月排行榜第三
2005年11月 C++ Builder大版内专家分月排行榜第三
本帖子已过去太久远了，不再提供回复功能。DELPHI RTTI实现非可视的功能插件 - 推酷
DELPHI RTTI实现非可视的功能插件
思路：通过数据字典定义BPL包名，然后定义BPL包里面的类名，然后定义类里面的方法名，最后定义方法的参数值。
可实现动态加载BPL，调用哪个BPL的哪个类的哪个方法并给该方法赋给指定的参数值，如果是函数还可以取得函数的返回值。
应用场合之一：中间件实现非可视功能插件。
下面来DEMO码子。
首先动态加载BPL包：
bplName := TPlug(TdxBarButton(Sender).Tag).bplN
if FileExists(bplName) then
unitClass := string(TPlug(TdxBarButton(Sender).Tag).UnitCalss);
plugName := TPlug(TdxBarButton(Sender).Tag).
powerValue := TPlug(TdxBarButton(Sender).Tag).powerV
if not bplList.ContainsKey(bplName) then
h := LoadPackage(bplName);
if h = 0 then
ShowTrayHint(bplName + '包加载失败')
bplList.Add(bplName, h);
然后获取BPL的对象
LContext: TRttiC
LPackage: TRttiP
LClass: TRttiInstanceT
aForm: TCustomF
LContext := TRttiContext.C
for LPackage in LContext.GetPackages() do
if SameText(ExtractFileName(LPackage.Name), bplFile) then
LClass := LPackage.FindType(unitClass) as TRttiInstanceTaForm := LClass.MetaclassType.Create as TCustomF
LContext.F
最后传递参数调用类的方法
TMyClass = class(TComponent)
procedure msg(const str: string);
function Add(const a,b: Integer): I
varForm1: TForm1;
implementation
{$R *.dfm}
{ TMyClass }
procedure TMyClass.msg(const str: string);
MessageDlg(str, mtInformation, [mbYes], 0);
function TMyClass.Add(const a, b: Integer): I
Result := a +
procedure TForm1.Button1Click(Sender: TObject);
m1,m2: TRttiM
r: TV //TRttiMethod.Invoke 的返回类型
t := TRttiContext.Create.GetType(TMyClass);
{获取 TMyClass 类的两个方法}
m1 := t.GetMethod('msg'); {procedure}
m2 := t.GetMethod('Add'); {function}
obj := TMyClass.Create(Self); {调用需要依赖一个已存在的对象}
{调用 msg 过程}m1.Invoke(obj, ['Delphi 2010']); {将弹出信息框}
{调用 Add 函数}
r := m2.Invoke(obj, [1, 2]); {其返回值是个 TValue 类型的结构}
ShowMessage(IntToStr(r.AsInteger)); {3}
代码只是为了演示这么个意思，你懂的。
以上的一切都是通过字典定义，RTTI运行时根据字典动态调用，如果你的开发框架里面或者中间件里面这样实现，简直帅呆了！
已发表评论数()
请填写推刊名
描述不能大于100个字符!
权限设置： 公开
仅自己可见
正文不准确
标题不准确
排版有问题
主题不准确
没有分页内容
图片无法显示
视频无法显示
与原文不一致奇技淫巧之获取Delphi所有类的类信息
这个绝大多数朋友应该是用不上的,纯属玩的.
昨天和业界某几个人讨论delphi的class的typeinfo问题,一般implementation部分实现的类在别处是拿不到类型信息的,尽管它有.
还比如私有的嵌套类在别处也拿不到.
于是写了几行代码扫描进程中所有类的类型信息,把这些Unpublic的classinfo也都翻出来.
本来纯属玩的.结果GetAllClassInfos_FromSystemModuleList发现如果把这个做成IDE插件跑起来居然可以看到一些敏感的类的信息,这些类估计都是在implementation部分实现的.比如TLicenceXXX并可以继续TypeInfo获取到它的成员变量以及函数.
Delphi遍历进程中所有Class的TypeInfo,即便是在implementation中的class或者其他
class的private的子class.
一般普通EXE中的TypeInfo存放在PAGE_EXECUTE_*的内存中,而BPL则存放在PAGE_READ_WRITE的内存中.
所以我们要做的是遍历可执内存的内存片,然后找出TypeInfo的特征.
这里我是只找Class的类型信息,特征是tkClass,classname合法,
沿着typedata中的ParentInfo往前追溯,直到找到TObject的类型信息.
那么认为这是个合法的class的TypeInfo
为了不产生class的类型信息本单元没用使用任何和class有关的东西,以免多产生class的类型信息
unit UnitClassInfoEx;
{$IFDEF VER230} // XE2
{$DEFINE HAS_UNITSCOPE}
{$IFDEF VER240} // XE3
{$DEFINE HAS_UNITSCOPE}
{$IFDEF VER250} // XE4
{$DEFINE HAS_UNITSCOPE}
{$IFDEF HAS_UNITSCOPE}
WinAPI.Windows, System.TypI
Windows, TypI
PTypeInfos = array of PTypeI
TModules = array of HM
{$IFNDEF CPUX64}
// Delphi 早期版本NativeInt计算起来会有内部错误
NativeUInt = C
NativeInt = I
// 获取一个指定模块中的类信息
function GetAllClassInfos_FromModule(AModule: HModule): PTypeI
// 从system的Modulelist里面枚举模块,获取模块中类信息
function GetAllClassInfos_FromSystemModuleList(): PTypeI
function GetProcessModules(): TM
implementation
MinClassTypeInfoSize = SizeOf(TTypeKind) + 2 { name } + SizeOf(Tclass) +
SizeOf(PPTypeInfo) + SizeOf(smallint) + 2 { unitname };
TMemoryRegion = record
BaseAddress: NativeI
MemorySize: NativeI
TMemoryRegions = array of TMemoryR
function EnumProcessModules(hProcess: TH lphModule: PDWORD; cb: DWORD;
var lpcbNeeded: DWORD): BOOL; external 'psapi.dll';
function GetProcessModules(): TM
cb: DWORD;
ret: BOOL;
if EnumProcessModules(GetCurrentProcess, nil, 0, cb) then
SetLength(Result, cb div SizeOf(HModule));
if not EnumProcessModules(GetCurrentProcess, @Result[0], cb, cb) then
function IsValidityMemoryBlock(MemoryRegions: TMemoryR
address, Size: NativeUInt): B
MemoryRegion: TMemoryR
mbi: TMemoryBasicI
if VirtualQueryEx(GetCurrentProcess, Pointer(address), mbi, SizeOf(mbi)) && 0
Result := F
//for MemoryRegion in MemoryRegions do
for i := low(MemoryRegions) to High(MemoryRegions) do
MemoryRegion := MemoryRegions[i];
if (address &= MemoryRegion.BaseAddress) and
((address + Size) &= (MemoryRegion.BaseAddress + MemoryRegion.MemorySize))
Result := T
procedure GetExecutableMemoryregions(var MemoryRegions: TMemoryRegions);
address: NativeUI
mbi: memory_basic_
processhandle: TH
stop: NativeUI
processhandle := GetCurrentP
SetLength(MemoryRegions, 0);
address := 0;
{$IFDEF CPUX64}
stop := $7FFFFFFFFFFFFFFF
stop := $7FFFFFFF;
while (address & stop) and (VirtualQueryEx(processhandle, Pointer(address),
mbi, SizeOf(mbi)) && 0) and ((address + mbi.RegionSize) & address) do
if (mbi.state = MEM_COMMIT) and
(((mbi.Protect and PAGE_EXECUTE_READ) = PAGE_EXECUTE_READ) or
((mbi.Protect and PAGE_READWRITE) = PAGE_READWRITE) or
((mbi.Protect and PAGE_EXECUTE_READWRITE) = PAGE_EXECUTE_READWRITE)) then
// executable
SetLength(MemoryRegions, Length(MemoryRegions) + 1);
MemoryRegions[Length(MemoryRegions) - 1].BaseAddress :=
NativeUInt(mbi.BaseAddress);
MemoryRegions[Length(MemoryRegions) - 1].MemorySize := mbi.RegionS
inc(address, mbi.RegionSize);
procedure GetExecutableMemoryRegionsInRang(address, stop: NativeUI
var MemoryRegions: TMemoryRegions);
mbi: memory_basic_
processhandle: TH
processhandle := GetCurrentP
SetLength(MemoryRegions, 0);
while (address & stop) and (VirtualQueryEx(processhandle, Pointer(address),
mbi, SizeOf(mbi)) && 0) and ((address + mbi.RegionSize) & address) do
if (mbi.state = MEM_COMMIT) and
(((mbi.Protect and PAGE_EXECUTE_READ) = PAGE_EXECUTE_READ) or
((mbi.Protect and PAGE_READWRITE) = PAGE_READWRITE) or
((mbi.Protect and PAGE_EXECUTE_READWRITE) = PAGE_EXECUTE_READWRITE)) then
// executable
SetLength(MemoryRegions, Length(MemoryRegions) + 1);
MemoryRegions[Length(MemoryRegions) - 1].BaseAddress :=
NativeUInt(mbi.BaseAddress);
MemoryRegions[Length(MemoryRegions) - 1].MemorySize := mbi.RegionS
inc(address, mbi.RegionSize);
function IsValidityClassInfo(ProcessMemoryRegions: TMemoryR p: PAnsiC
var RealResult: PTypeInfos): B
function IsValidityString(p: PAnsiC Length: Byte): B
我假定Delphi的ClassName都是英文.中文的话实际上会被UTF8编码.
另外这个也不包含编译器编译时产生临时类的类名.
临时类名为了不和程序员手写的类重名一般都有@#$之类的
Result := T
if p^ in ['a' .. 'z', 'A' .. 'Z', '_'] then
for i := 0 to Length - 1 do
begin { 类名有时会有. ,比如内嵌类,UnitName也会有.泛型类名会有&& }
if not(p[i] in ['a' .. 'z', '&', '&', 'A' .. 'Z', '_', '.', '0' .. '9'])
Result := F
Result := F
function FindTypeInfo(const RealResult: PTypeI p: Pointer): B
Result := F
for i := Low(RealResult) to High(RealResult) do
if RealResult[i] = p then
Result := T
procedure AddTypeInfo(var RealResult: PTypeI p: PTypeInfo);
//if FindTypeInfo(RealResult, p) then
if p^.Name = 'TForm1.TTT' then
SetLength(RealResult, Length(RealResult) + 1);
RealResult[Length(RealResult) - 1] :=
function IsValidityClassData(ProcessMemoryRegions: TMemoryR p: PAnsiC
var RealResult: PTypeInfos): B
td: PTypeD
parentInfo: PPTypeI
parentFinded : B
Result := F
td := PTypeData(p);
parentInfo := td.parentI
if not IsValidityString(@td.UnitName[1], Byte(td.UnitName[0])) then
if GetTypeData(TypeInfo(TObject)) = td then
Result := T
if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(parentInfo),
SizeOf(Pointer)) then
if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(parentInfo^),
MinClassTypeInfoSize) then
{ 遍历ParentInfo,直到找到TObject为止 }
parentFinded := FindTypeInfo(RealResult, parentInfo^);
if parentFinded
or IsValidityClassInfo(ProcessMemoryRegions, PAnsiChar(parentInfo^),
RealResult) then
Result := T
if not parentFinded then
AddTypeInfo(RealResult, ParentInfo^);
function IsValidityClassInfo(ProcessMemoryRegions: TMemoryR p: PAnsiC
var RealResult: PTypeInfos): B
classNamelen: B
classname:
Result := F
if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(p),
MinClassTypeInfoSize) then
if IsBadReadPtr(p, MinClassTypeInfoSize) then
if ord(p^) = ord(tkClass) then // ord(tkClass) = 7
classNamelen := ord(p^);
SetLength(classname, classNamelen);
Move((p + 1)^, PAnsiChar(classname)^, classNamelen);
if (classNamelen in [1 .. $FE]) then { Shortstring第一个字节是长度,最多254个 }
if IsValidityString(PAnsiChar(p), classNamelen) then
// OutputDebugStringA(PAnsiChar(classname));
inc(p, classNamelen);
if IsValidityClassData(ProcessMemoryRegions, p, RealResult) then
Result := T
procedure GetRegionClassInfos(ProcessMemoryRegions: TMemoryR
const MemoryRegion: TMemoryR var RealResult: PTypeInfos);
MaxAddr: NativeI
p := PAnsiChar(MemoryRegion.BaseAddress);
MaxAddr := MemoryRegion.BaseAddress + MemoryRegion.MemorySize -
MinClassTypeInfoS
while NativeInt(p) & MaxAddr do
if IsValidityClassInfo(ProcessMemoryRegions, p, RealResult) then
AddTypeInfo(RealResult, PTypeInfo(p));
// OutputDebugStringA(PAnsiChar('classname = ' + PTypeInfo(p).Name));
inc(p, MinClassTypeInfoSize);
function _GetAllClassInfos_FromModule(ProcessMemoryRegions: TMemoryR
AModule: HModule): PTypeI
MemoryRegions: TMemoryR
addr, stop: NativeUI
dos: PImageDosH
nt: PImageNtH
// SetLength(Result, 1);
// Result[0] := TypeInfo(TObject);
MemoryRegions :=
addr := AM
dos := PImageDosHeader(addr);
nt := PImageNtHeaders(addr + dos^._lfanew);
GetExecutableMemoryRegionsInRang(addr, addr + nt.OptionalHeader.SizeOfImage,
MemoryRegions);
for i := Low(MemoryRegions) to High(MemoryRegions) do
GetRegionClassInfos(ProcessMemoryRegions, MemoryRegions[i], Result);
// OutputDebugString(PChar(format('(%d;%d)',[MemoryRegions[i].BaseAddress,MemoryRegions[i].MemorySize])));
function GetAllClassInfos_FromModule(AModule: HModule): PTypeI
ProcessMemoryRegions: TMemoryR
GetExecutableMemoryregions(ProcessMemoryRegions);
Result := _GetAllClassInfos_FromModule(ProcessMemoryRegions, AModule);
function GetAllClassInfos_FromSystemModuleList(): PTypeI
ProcessMemoryRegions: TMemoryR
moduleTypeInfos: PTypeI
//SetLength(Result, 1);
//Result[0] := TypeInfo(TObject);
lm := LibModuleL
GetExecutableMemoryregions(ProcessMemoryRegions);
while True do
SetLength(s, MAX_PATH);
GetModuleFileName(lm.Instance, PChar(s), Length(s));
OutputDebugString(PChar(s));
moduleTypeInfos := _GetAllClassInfos_FromModule(ProcessMemoryRegions,
lm.Instance);
oldLen := Length(Result);
SetLength(Result, oldLen + Length(moduleTypeInfos));
for i := Low(moduleTypeInfos) to High(moduleTypeInfos) do
Result[oldLen + i] := moduleTypeInfos[i];
if lm.Next = nil then
lm := lm.N
此条目发表在, 分类目录。将加入收藏夹。君，已阅读到文档的结尾了呢~~
扫扫二维码，随身浏览文档
手机或平板扫扫即可继续访问
如何在运行时确定对象类型(RTTI)
举报该文档为侵权文档。
举报该文档含有违规或不良信息。
反馈该文档无法正常浏览。
举报该文档为重复文档。
推荐理由：
将文档分享至：
分享完整地址
文档地址：
粘贴到BBS或博客
flash地址：
支持嵌入FLASH地址的网站使用
html代码：
&embed src='/DocinViewer-4.swf' width='100%' height='600' type=application/x-shockwave-flash ALLOWFULLSCREEN='true' ALLOWSCRIPTACCESS='always'&&/embed&
450px*300px480px*400px650px*490px
支持嵌入HTML代码的网站使用
您的内容已经提交成功
您所提交的内容需要审核后才能发布，请您等待！
3秒自动关闭窗口