Другая идея состоит в том, чтобы сканировать информацию о типе, которая находится в верхней части списка экспортируемых функций, чтобы можно было пропустить перечисление далее. Информация типа экспортируется с именами, начинающимися с префикса '@ $ xp $'. Вот пример:
unit PackageUtils;
interface
uses
Windows, Classes, SysUtils, Contnrs, TypInfo;
type
TDelphiPackageList = class;
TDelphiPackage = class;
TDelphiProcess = class
private
FPackages: TDelphiPackageList;
function GetPackageCount: Integer;
function GetPackages(Index: Integer): TDelphiPackage;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Clear; virtual;
function FindPackage(Handle: HMODULE): TDelphiPackage;
procedure Reload; virtual;
property PackageCount: Integer read GetPackageCount;
property Packages[Index: Integer]: TDelphiPackage read GetPackages;
end;
TDelphiPackageList = class(TObjectList)
protected
function GetItem(Index: Integer): TDelphiPackage;
procedure SetItem(Index: Integer; APackage: TDelphiPackage);
public
function Add(APackage: TDelphiPackage): Integer;
function Extract(APackage: TDelphiPackage): TDelphiPackage;
function Remove(APackage: TDelphiPackage): Integer;
function IndexOf(APackage: TDelphiPackage): Integer;
procedure Insert(Index: Integer; APackage: TDelphiPackage);
function First: TDelphiPackage;
function Last: TDelphiPackage;
property Items[Index: Integer]: TDelphiPackage read GetItem write SetItem; default;
end;
TDelphiPackage = class
private
FHandle: THandle;
FInfoTable: Pointer;
FTypeInfos: TList;
procedure CheckInfoTable;
procedure CheckTypeInfos;
function GetDescription: string;
function GetFileName: string;
function GetInfoName(NameType: TNameType; Index: Integer): string;
function GetShortName: string;
function GetTypeInfoCount(Kinds: TTypeKinds): Integer;
function GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
public
constructor Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
destructor Destroy; override;
property Description: string read GetDescription;
property FileName: string read GetFileName;
property Handle: THandle read FHandle;
property ShortName: string read GetShortName;
property TypeInfoCount[Kinds: TTypeKinds]: Integer read GetTypeInfoCount;
property TypeInfos[Kinds: TTypeKinds; Index: Integer]: PTypeInfo read GetTypeInfos;
end;
implementation
uses
RTLConsts, SysConst,
PSAPI, ImageHlp;
{ Package info structures copied from SysUtils.pas }
type
PPkgName = ^TPkgName;
TPkgName = packed record
HashCode: Byte;
Name: array[0..255] of Char;
end;
PUnitName = ^TUnitName;
TUnitName = packed record
Flags : Byte;
HashCode: Byte;
Name: array[0..255] of Char;
end;
PPackageInfoHeader = ^TPackageInfoHeader;
TPackageInfoHeader = packed record
Flags: Cardinal;
RequiresCount: Integer;
{Requires: array[0..9999] of TPkgName;
ContainsCount: Integer;
Contains: array[0..9999] of TUnitName;}
end;
TEnumModulesCallback = function (Module: HMODULE; Data: Pointer = nil): Boolean;
TEnumModulesProc = function (Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
const
STypeInfoPrefix = '@$xp$';
var
EnumModules: TEnumModulesProc = nil;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; forward;
function AddPackage(Module: HMODULE; Data: {TDelphiPackageList} Pointer): Boolean;
var
InfoTable: Pointer;
begin
Result := False;
if (Module <> HInstance) then
begin
InfoTable := PackageInfoTable(Module);
if Assigned(InfoTable) then
TDelphiPackageList(Data).Add(TDelphiPackage.Create(Module, InfoTable));
end;
end;
function GetPackageDescription(Module: HMODULE): string;
var
ResInfo: HRSRC;
ResData: HGLOBAL;
begin
Result := '';
ResInfo := FindResource(Module, 'DESCRIPTION', RT_RCDATA);
if ResInfo <> 0 then
begin
ResData := LoadResource(Module, ResInfo);
if ResData <> 0 then
try
Result := PWideChar(LockResource(ResData));
UnlockResource(ResData);
finally
FreeResource(ResData);
end;
end;
end;
function EnumModulesPS(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
var
ProcessHandle: THandle;
SizeNeeded: Cardinal;
P, ModuleHandle: PDWORD;
I: Integer;
begin
Result := False;
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, GetCurrentProcessId);
if ProcessHandle = 0 then
RaiseLastOSError;
try
SizeNeeded := 0;
EnumProcessModules(ProcessHandle, nil, 0, SizeNeeded);
if SizeNeeded = 0 then
Exit;
P := AllocMem(SizeNeeded);
try
if EnumProcessModules(ProcessHandle, P, SizeNeeded, SizeNeeded) then
begin
ModuleHandle := P;
for I := 0 to SizeNeeded div SizeOf(DWORD) - 1 do
begin
if Callback(ModuleHandle^, Data) then
Exit;
Inc(ModuleHandle);
end;
Result := True;
end;
finally
FreeMem(P);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
function EnumModulesTH(Callback: TEnumModulesCallback; Data: Pointer = nil): Boolean;
begin
Result := False;
// todo win9x?
end;
function PackageInfoTable(Module: HMODULE): PPackageInfoHeader;
var
ResInfo: HRSRC;
Data: THandle;
begin
Result := nil;
ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA);
if ResInfo <> 0 then
begin
Data := LoadResource(Module, ResInfo);
if Data <> 0 then
try
Result := LockResource(Data);
UnlockResource(Data);
finally
FreeResource(Data);
end;
end;
end;
{ TDelphiProcess private }
function TDelphiProcess.GetPackageCount: Integer;
begin
Result := FPackages.Count;
end;
function TDelphiProcess.GetPackages(Index: Integer): TDelphiPackage;
begin
Result := FPackages[Index];
end;
{ TDelphiProcess public }
constructor TDelphiProcess.Create;
begin
inherited Create;
FPackages := TDelphiPackageList.Create;
Reload;
end;
destructor TDelphiProcess.Destroy;
begin
FPackages.Free;
inherited Destroy;
end;
procedure TDelphiProcess.Clear;
begin
FPackages.Clear;
end;
function TDelphiProcess.FindPackage(Handle: HMODULE): TDelphiPackage;
var
I: Integer;
begin
Result := nil;
for I := 0 to FPackages.Count - 1 do
if FPackages[I].Handle = Handle then
begin
Result := FPackages[I];
Break;
end;
end;
procedure TDelphiProcess.Reload;
begin
Clear;
if Assigned(EnumModules) then
EnumModules(AddPackage, FPackages);
end;
{ TDelphiPackageList protected }
function TDelphiPackageList.GetItem(Index: Integer): TDelphiPackage;
begin
Result := TDelphiPackage(inherited GetItem(Index));
end;
procedure TDelphiPackageList.SetItem(Index: Integer; APackage: TDelphiPackage);
begin
inherited SetItem(Index, APackage);
end;
{ TDelphiPackageList public }
function TDelphiPackageList.Add(APackage: TDelphiPackage): Integer;
begin
Result := inherited Add(APackage);
end;
function TDelphiPackageList.Extract(APackage: TDelphiPackage): TDelphiPackage;
begin
Result := TDelphiPackage(inherited Extract(APackage));
end;
function TDelphiPackageList.First: TDelphiPackage;
begin
Result := TDelphiPackage(inherited First);
end;
function TDelphiPackageList.IndexOf(APackage: TDelphiPackage): Integer;
begin
Result := inherited IndexOf(APackage);
end;
procedure TDelphiPackageList.Insert(Index: Integer; APackage: TDelphiPackage);
begin
inherited Insert(Index, APackage);
end;
function TDelphiPackageList.Last: TDelphiPackage;
begin
Result := TDelphiPackage(inherited Last);
end;
function TDelphiPackageList.Remove(APackage: TDelphiPackage): Integer;
begin
Result := inherited Remove(APackage);
end;
{ TDelphiPackage private }
procedure TDelphiPackage.CheckInfoTable;
begin
if not Assigned(FInfoTable) then
FInfoTable := PackageInfoTable(Handle);
if not Assigned(FInfoTable) then
raise EPackageError.CreateFmt(SCannotReadPackageInfo, [ExtractFileName(GetModuleName(Handle))]);
end;
procedure TDelphiPackage.CheckTypeInfos;
var
ExportDir: PImageExportDirectory;
Size: DWORD;
Names: PDWORD;
I: Integer;
begin
if not Assigned(FTypeInfos) then
begin
FTypeInfos := TList.Create;
try
Size := 0;
ExportDir := ImageDirectoryEntryToData(Pointer(Handle), True, IMAGE_DIRECTORY_ENTRY_EXPORT, Size);
if not Assigned(ExportDir) then
Exit;
Names := PDWORD(DWORD(Handle) + DWORD(ExportDir^.AddressOfNames));
for I := 0 to ExportDir^.NumberOfNames - 1 do
begin
if StrLIComp(PChar(DWORD(Handle) + Names^), STypeInfoPrefix, StrLen(STypeInfoPrefix)) <> 0 then
Break;
FTypeInfos.Add(GetProcAddress(Handle, PChar(DWORD(Handle) + Names^)));
Inc(Names);
end;
except
FreeAndNil(FTypeInfos);
raise;
end;
end;
end;
function TDelphiPackage.GetDescription: string;
begin
Result := GetPackageDescription(Handle);
end;
function TDelphiPackage.GetFileName: string;
begin
Result := GetModuleName(FHandle);
end;
function TDelphiPackage.GetInfoName(NameType: TNameType; Index: Integer): string;
var
P: Pointer;
Count: Integer;
I: Integer;
begin
Result := '';
CheckInfoTable;
Count := PPackageInfoHeader(FInfoTable)^.RequiresCount;
P := Pointer(Cardinal(FInfoTable) + SizeOf(TPackageInfoHeader));
case NameType of
ntContainsUnit:
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PUnitName(P)^.Name;
end;
end;
ntRequiresPackage:
if (Index >= 0) and (Index < Count) then
begin
for I := 0 to Index - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Result := PPkgName(P)^.Name;
end;
ntDcpBpiName:
if PPackageInfoHeader(FInfoTable)^.Flags and pfPackageModule <> 0 then
begin
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PPkgName(P)^.Name) + 2);
Count := Integer(P^);
P := Pointer(Cardinal(P) + SizeOf(Integer));
for I := 0 to Count - 1 do
P := Pointer(Cardinal(P) + StrLen(PUnitName(P)^.Name) + 3);
Result := PPkgName(P)^.Name;
end;
end;
end;
function TDelphiPackage.GetShortName: string;
begin
Result := GetInfoName(ntDcpBpiName, 0);
end;
function TDelphiPackage.GetTypeInfoCount(Kinds: TTypeKinds): Integer;
var
I: Integer;
begin
CheckTypeInfos;
Result := 0;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
Inc(Result);
end;
function TDelphiPackage.GetTypeInfos(Kinds: TTypeKinds; Index: Integer): PTypeInfo;
var
I, J: Integer;
begin
CheckTypeInfos;
Result := nil;
J := -1;
for I := 0 to FTypeInfos.Count - 1 do
if (Kinds = []) or (PTypeInfo(FTypeInfos[I])^.Kind in Kinds) then
begin
Inc(J);
if J = Index then
begin
Result := FTypeInfos[I];
Break;
end;
end;
end;
{ TDelphiPackage public }
constructor TDelphiPackage.Create(AHandle: HMODULE; AInfoTable: Pointer = nil);
begin
inherited Create;
FHandle := AHandle;
FInfoTable := AInfoTable;
FTypeInfos := nil;
end;
destructor TDelphiPackage.Destroy;
begin
FTypeInfos.Free;
inherited Destroy;
end;
initialization
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
EnumModules := EnumModulesTH;
VER_PLATFORM_WIN32_NT:
EnumModules := EnumModulesPS;
else
EnumModules := nil;
end;
finalization
end.
Блок тестового пакета, установленного в IDE:
unit Test;
interface
uses
SysUtils, Classes,
ToolsAPI;
type
TTestWizard = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
private
{ IOTAWizard }
procedure Execute;
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ IOTAMenuWizard }
function GetMenuText: string;
end;
implementation
uses
TypInfo,
PackageUtils;
function AncestryStr(AClass: TClass): string;
begin
Result := '';
if not Assigned(AClass) then
Exit;
Result := AncestryStr(AClass.ClassParent);
if Result <> '' then
Result := Result + '\';
Result := Result + AClass.ClassName;
end;
procedure ShowMessage(const S: string);
begin
with BorlandIDEServices as IOTAMessageServices do
AddTitleMessage(S);
end;
{ TTestWizard }
procedure TTestWizard.Execute;
var
Process: TDelphiProcess;
I, J: Integer;
Package: TDelphiPackage;
PInfo: PTypeInfo;
PData: PTypeData;
begin
Process := TDelphiProcess.Create;
for I := 0 to Process.PackageCount - 1 do
begin
Package := Process.Packages[I];
for J := 0 to Package.TypeInfoCount[[tkClass]] - 1 do
begin
PInfo := Package.TypeInfos[[tkClass], J];
PData := GetTypeData(PInfo);
ShowMessage(Format('%s: %s.%s (%s)', [Package.ShortName, PData^.UnitName, PInfo^.Name, AncestryStr(PData^.ClassType)]));
end;
end;
end;
function TTestWizard.GetIDString: string;
begin
Result := 'TOndrej.TestWizard';
end;
function TTestWizard.GetName: string;
begin
Result := 'Test';
end;
function TTestWizard.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
function TTestWizard.GetMenuText: string;
begin
Result := 'Test';
end;
var
Index: Integer = -1;
initialization
with BorlandIDEServices as IOTAWizardServices do
Index := AddWizard(TTestWizard.Create);
finalization
if Index <> -1 then
with BorlandIDEServices as IOTAWizardServices do
RemoveWizard(Index);
end.
Вы должны добавить designide к вашему требованию. При установке этого пакета дизайна новый пункт меню «Тест» должен появиться в меню «Справка» Delphi. Нажатие на нее должно отобразить все загруженные классы в окне сообщений.