文档章节

获取Delphi所有类的类信息

simpower
 simpower
发布于 2016/03/01 19:54
字数 1256
阅读 72
收藏 1
{
  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;
 
interface
 
uses
{$IFDEF VER230} // XE2
{$DEFINE HAS_UNITSCOPE}
{$ENDIF}
{$IFDEF VER240} // XE3
{$DEFINE HAS_UNITSCOPE}
{$ENDIF}
{$IFDEF VER250} // XE4
{$DEFINE HAS_UNITSCOPE}
{$ENDIF}
{$IFDEF HAS_UNITSCOPE}
  WinAPI.Windows, System.TypInfo;
{$ELSE}
  Windows, TypInfo;
{$ENDIF}
 
type
  PTypeInfos = array of PTypeInfo;
  TModules = array of HModule;
{$IFNDEF CPUX64}
  // Delphi 早期版本NativeInt计算起来会有内部错误
  NativeUInt = Cardinal;
  NativeInt = Integer;
{$ENDIF}
  // 获取一个指定模块中的类信息
function GetAllClassInfos_FromModule(AModule: HModule): PTypeInfos;
// 从system的Modulelist里面枚举模块,获取模块中类信息
function GetAllClassInfos_FromSystemModuleList(): PTypeInfos;
 
function GetProcessModules(): TModules;
 
implementation
 
const
  MinClassTypeInfoSize = SizeOf(TTypeKind) + 2 { name } + SizeOf(Tclass) +
    SizeOf(PPTypeInfo) + SizeOf(smallint) + 2 { unitname };
 
type
  TMemoryRegion = record
    BaseAddress: NativeInt;
    MemorySize: NativeInt;
  end;
 
  TMemoryRegions = array of TMemoryRegion;
 
function EnumProcessModules(hProcess: THandle; lphModule: PDWORD; cb: DWORD;
  var lpcbNeeded: DWORD): BOOL; stdcall; external 'psapi.dll';
 
function GetProcessModules(): TModules;
var
  cb: DWORD;
  ret: BOOL;
begin
  if EnumProcessModules(GetCurrentProcess, nil, 0, cb) then
  begin
    SetLength(Result, cb div SizeOf(HModule));
    if not EnumProcessModules(GetCurrentProcess, @Result[0], cb, cb) then
      Result := nil;
  end;
end;
 
function IsValidityMemoryBlock(MemoryRegions: TMemoryRegions;
  address, Size: NativeUInt): Boolean;
var
  MemoryRegion: TMemoryRegion;
  i: Integer;
  mbi: TMemoryBasicInformation;
begin
  {
    if VirtualQueryEx(GetCurrentProcess, Pointer(address), mbi, SizeOf(mbi)) <> 0
    then
    begin
    GetTickCount;
    end;
  }
  Result := False;
 
  //for MemoryRegion in MemoryRegions do
  for i := low(MemoryRegions) to High(MemoryRegions) do
  begin
    MemoryRegion := MemoryRegions[i];
    if (address >= MemoryRegion.BaseAddress) and
      ((address + Size) <= (MemoryRegion.BaseAddress + MemoryRegion.MemorySize))
    then
    begin
      Result := True;
      Exit;
    end;
  end;
end;
 
procedure GetExecutableMemoryregions(var MemoryRegions: TMemoryRegions);
var
  address: NativeUInt;
  mbi: memory_basic_information;
  processhandle: THandle;
  stop: NativeUInt;
begin
  processhandle := GetCurrentProcess;
  SetLength(MemoryRegions, 0);
  address := 0;
{$IFDEF CPUX64}
  stop := $7FFFFFFFFFFFFFFF
{$ELSE}
  stop := $7FFFFFFF;
{$ENDIF}
  while (address < stop) and (VirtualQueryEx(processhandle, Pointer(address),
    mbi, SizeOf(mbi)) <> 0) and ((address + mbi.RegionSize) > address) do
  begin
    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
    begin
      // executable
      SetLength(MemoryRegions, Length(MemoryRegions) + 1);
      MemoryRegions[Length(MemoryRegions) - 1].BaseAddress :=
        NativeUInt(mbi.BaseAddress);
      MemoryRegions[Length(MemoryRegions) - 1].MemorySize := mbi.RegionSize;
    end;
 
    inc(address, mbi.RegionSize);
  end;
 
end;
 
procedure GetExecutableMemoryRegionsInRang(address, stop: NativeUInt;
  var MemoryRegions: TMemoryRegions);
var
  mbi: memory_basic_information;
  processhandle: THandle;
begin
  processhandle := GetCurrentProcess;
  SetLength(MemoryRegions, 0);
 
  while (address < stop) and (VirtualQueryEx(processhandle, Pointer(address),
    mbi, SizeOf(mbi)) <> 0) and ((address + mbi.RegionSize) > address) do
  begin
    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
    begin
      // executable
      SetLength(MemoryRegions, Length(MemoryRegions) + 1);
      MemoryRegions[Length(MemoryRegions) - 1].BaseAddress :=
        NativeUInt(mbi.BaseAddress);
      MemoryRegions[Length(MemoryRegions) - 1].MemorySize := mbi.RegionSize;
    end;
 
    inc(address, mbi.RegionSize);
  end;
 
end;
 
function IsValidityClassInfo(ProcessMemoryRegions: TMemoryRegions; p: PAnsiChar;
  var RealResult: PTypeInfos): Boolean; forward;
 
function IsValidityString(p: PAnsiChar; Length: Byte): Boolean;
var
  i: Integer;
begin
  {
    我假定Delphi的ClassName都是英文.中文的话实际上会被UTF8编码.
    另外这个也不包含编译器编译时产生临时类的类名.
    临时类名为了不和程序员手写的类重名一般都有@#$之类的
  }
  Result := True;
  if p^ in ['a' .. 'z', 'A' .. 'Z', '_'] then
  begin
    for i := 0 to Length - 1 do
    begin { 类名有时会有. ,比如内嵌类,UnitName也会有.泛型类名会有<> }
      if not(p[i] in ['a' .. 'z', '<', '>', 'A' .. 'Z', '_', '.', '0' .. '9'])
      then
      begin
        Result := False;
        Exit;
      end;
    end;
  end
  else
    Result := False;
end;
 
function FindTypeInfo(const RealResult: PTypeInfos; p: Pointer): Boolean;
var
  i: Integer;
begin
  Result := False;
  for i := Low(RealResult) to High(RealResult) do
    if RealResult[i] = p then
    begin
      Result := True;
      Break;
    end;
end;
 
procedure AddTypeInfo(var RealResult: PTypeInfos; p: PTypeInfo);
begin
  //if FindTypeInfo(RealResult, p) then
  if p^.Name = 'TForm1.TTT' then
 
  begin
    GetTickCount;
    //Exit;
  end;
  SetLength(RealResult, Length(RealResult) + 1);
  RealResult[Length(RealResult) - 1] := p;
end;
 
function IsValidityClassData(ProcessMemoryRegions: TMemoryRegions; p: PAnsiChar;
  var RealResult: PTypeInfos): Boolean;
var
  td: PTypeData;
  parentInfo: PPTypeInfo;
  parentFinded : Boolean;
begin
  Result := False;
  td := PTypeData(p);
  parentInfo := td.parentInfo;
  if not IsValidityString(@td.UnitName[1], Byte(td.UnitName[0])) then
    Exit;
  if GetTypeData(TypeInfo(TObject)) = td then
  begin
    Result := True;
    Exit;
  end;
  if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(parentInfo),
    SizeOf(Pointer)) then
    Exit;
  if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(parentInfo^),
    MinClassTypeInfoSize) then
    Exit;
  { 遍历ParentInfo,直到找到TObject为止 }
  parentFinded := FindTypeInfo(RealResult, parentInfo^);
  if parentFinded
    or IsValidityClassInfo(ProcessMemoryRegions, PAnsiChar(parentInfo^),
    RealResult) then
  begin
    Result := True;
    if not parentFinded then
      AddTypeInfo(RealResult, ParentInfo^);
    Exit;
  end;
end;
 
function IsValidityClassInfo(ProcessMemoryRegions: TMemoryRegions; p: PAnsiChar;
  var RealResult: PTypeInfos): Boolean;
var
  classNamelen: Byte;
  classname: ansistring;
begin
  Result := False;
  if not IsValidityMemoryBlock(ProcessMemoryRegions, NativeUInt(p),
    MinClassTypeInfoSize) then
    Exit;
  if IsBadReadPtr(p, MinClassTypeInfoSize) then
    Exit;
 
  if ord(p^) = ord(tkClass) then // ord(tkClass) = 7
  begin
    inc(p);
    classNamelen := ord(p^);
    SetLength(classname, classNamelen);
    Move((p + 1)^, PAnsiChar(classname)^, classNamelen);
 
    if (classNamelen in [1 .. $FE]) then { Shortstring第一个字节是长度,最多254个 }
    begin
      inc(p);
      if IsValidityString(PAnsiChar(p), classNamelen) then
      begin
        // OutputDebugStringA(PAnsiChar(classname));
        inc(p, classNamelen);
        if IsValidityClassData(ProcessMemoryRegions, p, RealResult) then
        begin
          Result := True;
          Exit;
        end;
      end;
    end;
  end;
end;
 
procedure GetRegionClassInfos(ProcessMemoryRegions: TMemoryRegions;
  const MemoryRegion: TMemoryRegion; var RealResult: PTypeInfos);
var
  p: PAnsiChar;
  MaxAddr: NativeInt;
begin
  p := PAnsiChar(MemoryRegion.BaseAddress);
  MaxAddr := MemoryRegion.BaseAddress + MemoryRegion.MemorySize -
    MinClassTypeInfoSize;
  while NativeInt(p) < MaxAddr do
  begin
    if IsValidityClassInfo(ProcessMemoryRegions, p, RealResult) then
    begin
      AddTypeInfo(RealResult, PTypeInfo(p));
      // OutputDebugStringA(PAnsiChar('classname = ' + PTypeInfo(p).Name));
      inc(p, MinClassTypeInfoSize);
    end
    else
      inc(p);
  end;
end;
 
function _GetAllClassInfos_FromModule(ProcessMemoryRegions: TMemoryRegions;
  AModule: HModule): PTypeInfos;
var
  MemoryRegions: TMemoryRegions;
  i: Integer;
  addr, stop: NativeUInt;
  dos: PImageDosHeader;
  nt: PImageNtHeaders;
begin
  Result := nil;
  // SetLength(Result, 1);
  // Result[0] := TypeInfo(TObject);
  //
  MemoryRegions := nil;
  addr := AModule;
  dos := PImageDosHeader(addr);
  nt := PImageNtHeaders(addr + dos^._lfanew);
 
  GetExecutableMemoryRegionsInRang(addr, addr + nt.OptionalHeader.SizeOfImage,
    MemoryRegions);
  for i := Low(MemoryRegions) to High(MemoryRegions) do
  begin
    GetRegionClassInfos(ProcessMemoryRegions, MemoryRegions[i], Result);
    // OutputDebugString(PChar(format('(%d;%d)',[MemoryRegions[i].BaseAddress,MemoryRegions[i].MemorySize])));
  end;
end;
 
function GetAllClassInfos_FromModule(AModule: HModule): PTypeInfos;
var
  ProcessMemoryRegions: TMemoryRegions;
begin
  GetExecutableMemoryregions(ProcessMemoryRegions);
  Result := _GetAllClassInfos_FromModule(ProcessMemoryRegions, AModule);
end;
 
function GetAllClassInfos_FromSystemModuleList(): PTypeInfos;
var
  ProcessMemoryRegions: TMemoryRegions;
  lm: PLibModule;
  moduleTypeInfos: PTypeInfos;
  i: Integer;
  oldLen: Integer;
  s: string;
begin
  Result := nil;
  //SetLength(Result, 1);
  //Result[0] := TypeInfo(TObject);
  //
  lm := LibModuleList;
  GetExecutableMemoryregions(ProcessMemoryRegions);
  while True do
  begin
    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
      Break;
    lm := lm.Next;
  end;
end;
 
end.


本文转载自:http://www.cnblogs.com/key-ok/p/3506509.html

simpower
粉丝 28
博文 659
码字总数 47375
作品 0
海淀
程序员
私信 提问
关于C++类静态成员在Delphi中实现的思考

关于C++类静态成员在Delphi中实现的思考   没有用过Version 7 以后的Delphi版本,即便5、6、7版本,我也不能够说了解较深。因此,本文可能杞人忧天。   一、为什么需要静态成员    比如...

geek_loser
2014/11/11
138
0
不在乎y/govcl

govcl 目录 项目介绍 重要说明 WIKI 使用方法 icon及manifest文件集成 关于跨平台问题 项目中的包说明 实例类说明 支持的组件列表 截图 备注 作者信息 项目介绍 1、由于现有第三方的Go UI库不...

不在乎y
2017/10/10
0
0
[转] Java中调用Delphi编写的DLL

有些时候,要写一些程序,在 JAVA 里面好难实现, 但如果使用其它编程语言却又比较容易时,我们不妨通过 JNI 来让不同语言的程序共同完成. JNI 的教程, 网上 C 的比较多,Java 也提供了 javah.ex...

鉴客
2010/10/28
2.8K
1
Java中调用Delphi编写的DLL

有些时候,要写一些程序,在 JAVA 里面好难实现, 但如果使用其它编程语言却又比较容易时,我们不妨通过 JNI 来让不同语言的程序共同完成. JNI 的教程, 网上 C 的比较多,Java 也提供了 javah.ex...

geek_loser
2014/09/26
815
0
Delphi实现WebService带身份认证的数据传输

Delphi实现WebService带身份认证的数据传输 WebService使得不同开发工具开发出来的程序可以在网络连通的环境下相互通信,它最大的特点就是标准化(基于XML的一系列标准)带来的跨平台、跨开发...

vga
2014/11/25
332
0

没有更多内容

加载失败,请刷新页面

加载更多

可见性有序性,Happens-before来搞定

写在前面 上一篇文章并发 Bug 之源有三,请睁大眼睛看清它们 谈到了可见性/原子性/有序性三个问题,这些问题通常违背我们的直觉和思考模式,也就导致了很多并发 Bug 为了解决 CPU,内存,IO ...

tan日拱一兵
29分钟前
2
0
网络七层模型与TCP/UDP

为了使全球范围内不同的计算机厂家能够相互之间能够比较协调的进行通信,这个时候就有必要建立一种全球范围内的通用协议,以规范各个厂家之间的通信接口,这就是网络七层模型的由来。本文首先...

爱宝贝丶
32分钟前
2
0
Jenkins World 贡献者峰会及专家答疑展位

本文首发于:Jenkins 中文社区 原文链接 作者:Marky Jackson 译者:shunw Jenkins World 贡献者峰会及专家答疑展位 本文为 Jenkins World 贡献者峰会活动期间的记录 Jenkins 15周岁啦!Jen...

Jenkins中文社区
50分钟前
8
0
杂谈:面向微服务的体系结构评审中需要问的三个问题

面向微服务的体系结构如今风靡全球。这是因为更快的部署节奏和更低的成本是面向微服务的体系结构的基本承诺。 然而,对于大多数试水的公司来说,开发活动更多的是将现有的单块应用程序转换为...

liululee
今天
7
0
OSChina 周二乱弹 —— 我等饭呢,你是不是来错食堂了?

Osc乱弹歌单(2019)请戳(这里) 【今日歌曲】 @ 自行车丢了:给主编推荐首歌 《クリスマスの夜》- 岡村孝子 手机党少年们想听歌,请使劲儿戳(这里) @烽火燎原 :国庆快来,我需要长假! ...

小小编辑
今天
832
11

没有更多内容

加载失败,请刷新页面

加载更多

返回顶部
顶部