1781 lines
70 KiB
Plaintext
1781 lines
70 KiB
Plaintext
// ***************************************************************
|
|
// madTools.pas version: 1.3.7 · date: 2023-03-08
|
|
// -------------------------------------------------------------
|
|
// several basic tool functions
|
|
// -------------------------------------------------------------
|
|
// Copyright (C) 1999 - 2023 www.madshi.net, All Rights Reserved
|
|
// ***************************************************************
|
|
|
|
// 2023-03-08 1.3.7 added support for detecting Windows 11
|
|
// 2021-05-12 1.3.6 added support for detecting Windows 2019
|
|
// 2018-05-17 1.3.5 added "nil" detection in ExportToFunc helper function
|
|
// 2017-03-13 1.3.4 fixed crash with Windows XP Black editions
|
|
// 2015-04-20 1.3.3 (1) added detection for Windows 8.1, Windows 10 etc
|
|
// (2) fixed MsgHandlerWindow atom leak
|
|
// 2012-09-05 1.3.2 added unmangle support for XE3 x64 package export names
|
|
// 2012-07-03 1.3.1 added UIPI workaround to MsgHandler functionality
|
|
// 2012-04-03 1.3.0 (1) added x64 support
|
|
// (2) most functions are now available as xxx, xxxA and xxxW
|
|
// 2011-03-27 1.2w (1) added GetFileVersionStr
|
|
// (2) added special handling for "wine"
|
|
// 2009-07-14 1.2v added osWin2008, osWin7, osWin2008r2
|
|
// 2009-02-09 1.2u (1) Delphi 2009 support
|
|
// (2) added some unicode function overloads
|
|
// 2006-11-28 1.2t (1) limited support for 64bit modules added
|
|
// (2) "OS" detects Vista, Media Center, x64, etc
|
|
// 2005-06-11 1.2s "ResToStr" returns a resource as binary data in a string
|
|
// 2005-02-05 1.2r GetImageNtHeaders avoids inconvenient debugger exceptions
|
|
// 2004-03-12 1.2q AMD64 NX: New -> VirtualAlloc (in MethodToProcedure)
|
|
// 2003-10-05 1.2p (1) support for Windows 2003 added
|
|
// (2) OS.enum renamed to OS.Enum -> BCB support
|
|
// 2003-06-09 1.2o (1) GetImageProcAddress now handles forwarded APIs correctly
|
|
// (2) minor bug in GetImageNtHeaders fixed
|
|
// (3) some other minor bug fixes / improvements
|
|
// 2002-12-27 1.2m FindModule + GetImageProcName added
|
|
// 2002-11-20 1.2l make OS.description work even after madTools.finalization
|
|
// 2002-10-25 1.2k some low level module image parsing functions added
|
|
// 2002-09-05 1.2j GetFreeSystemResources now simply returns 0 in NT family
|
|
// 2002-06-04 1.2i little NT4 bug workaround, see MsgHandlerWindow
|
|
// 2002-04-24 1.2h mutex and window class name now process+module dependent
|
|
// 2002-02-24 1.2g MsgHandler is now using mutex instead of critical section
|
|
// 2002-02-16 1.2f MsgHandler stuff rewritten, thread safe etc.
|
|
// 2001-07-23 1.2e Add/DelMsgHandler now can also work with other threads
|
|
// 2001-07-22 1.2d fix for wrong OS information ("setup.exe" on ME)
|
|
// 2001-07-15 1.2c new functions added (1) GetFreeSystemResources
|
|
// (2) GetFileVersion / FileVersionToStr
|
|
// 2001-05-19 1.2b osWinXP added
|
|
// 2001-04-10 1.2a TOS.description added
|
|
// 2000-11-22 1.2 MsgHandlerWindow (and related) functionality added
|
|
// 2000-07-25 1.1a minor changes in order to get rid of SysUtils
|
|
|
|
unit madTools;
|
|
|
|
{$I mad.inc}
|
|
|
|
interface
|
|
|
|
uses Windows, madTypes;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// types for the "OS" function
|
|
TOsEnum = (osNone, osWin95, osWin95osr2, osWin98, osWin98se, osWinME, osWin9xNew,
|
|
osWinNtOld, osWinNt4, osWin2k, osWinXP, osWin2003, osWinVista, osWin2008, osWin7, osWin2008r2, osWin8, osWin2012, osWin81, osWin2012r2, osWin10, osWin2016, osWin2019, osWin11, osWinNtNew);
|
|
TOS = record
|
|
major : cardinal;
|
|
minor : cardinal;
|
|
build : cardinal;
|
|
spStr : UnicodeString;
|
|
win9x : boolean;
|
|
win9xEnum : TOsEnum;//osNone..osWin9xNew; BCB doesn't like this
|
|
winNt : boolean;
|
|
winNtEnum : TOsEnum;
|
|
Enum : TOsEnum;
|
|
x64 : boolean;
|
|
spNo : cardinal;
|
|
description : UnicodeString;
|
|
end;
|
|
|
|
const
|
|
// operating system strings
|
|
COsDescr : array [TOsEnum] of PAnsiChar =
|
|
('None', 'Windows 95', 'Windows 95 OSR-2', 'Windows 98', 'Windows 98 SE',
|
|
'Windows ME', 'Windows 9x New',
|
|
'Windows NT 3', 'Windows NT 4', 'Windows 2000', 'Windows XP',
|
|
'Windows 2003', 'Windows Vista', 'Windows 2008', 'Windows 7', 'Windows 2008 R2',
|
|
'Windows 8', 'Windows 2012', 'Windows 8.1', 'Windows 2012 R2', 'Windows 10', 'Windows 2016', 'Windows 2019', 'Windows 11', 'Windows NT New');
|
|
|
|
// Tests which system is running...
|
|
function OS : TOS;
|
|
|
|
// ***************************************************************
|
|
|
|
{$ifndef win64}
|
|
|
|
// returns the 9x resource usage; 0: System; 1: GDI; 2: User
|
|
function GetFreeSystemResources (resource: word) : word;
|
|
|
|
{$endif}
|
|
|
|
// ***************************************************************
|
|
|
|
// returns the short respectively the long variant of the filename
|
|
function GetShortFileName (fileName: AnsiString) : AnsiString; {$ifdef UnicodeOverloads} overload;
|
|
function GetShortFileName (fileName: UnicodeString) : UnicodeString; overload; {$endif}
|
|
function GetLongFileName (fileName: AnsiString) : AnsiString; {$ifdef UnicodeOverloads} overload;
|
|
function GetLongFileName (fileName: UnicodeString) : UnicodeString; overload; {$endif}
|
|
|
|
var
|
|
GetShortFileNameA : function (fileName: AnsiString) : AnsiString = GetShortFileName;
|
|
GetLongFileNameA : function (fileName: AnsiString) : AnsiString = GetLongFileName;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
var
|
|
GetShortFileNameW : function (fileName: UnicodeString) : UnicodeString = GetShortFileName;
|
|
GetLongFileNameW : function (fileName: UnicodeString) : UnicodeString = GetLongFileName;
|
|
{$else}
|
|
function GetShortFileNameW (fileName: UnicodeString) : UnicodeString;
|
|
function GetLongFileNameW (fileName: UnicodeString) : UnicodeString;
|
|
{$endif}
|
|
|
|
// ***************************************************************
|
|
|
|
// returns the version number of a file, can be used on e.g. system dlls
|
|
function GetFileVersion (const file_: AnsiString) : int64; {$ifdef UnicodeOverloads} overload;
|
|
function GetFileVersion (const file_: UnicodeString) : int64; overload; {$endif}
|
|
function GetFileVersionStr (const file_: AnsiString) : AnsiString; {$ifdef UnicodeOverloads} overload;
|
|
function GetFileVersionStr (const file_: UnicodeString) : UnicodeString; overload; {$endif}
|
|
function FileVersionToStr (version : int64) : AnsiString;
|
|
function FileVersionToStrW (version : int64) : UnicodeString;
|
|
|
|
var
|
|
GetFileVersionA : function (const file_: AnsiString) : int64 = GetFileVersion;
|
|
GetFileVersionStrA : function (const file_: AnsiString) : AnsiString = GetFileVersionStr;
|
|
FileVersionToStrA : function (version : int64) : AnsiString = FileVersionToStr;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
var
|
|
GetFileVersionW : function (const file_: UnicodeString) : int64 = GetFileVersion;
|
|
GetFileVersionStrW : function (const file_: UnicodeString) : UnicodeString = GetFileVersionStr;
|
|
{$else}
|
|
function GetFileVersionW (const file_: UnicodeString) : int64;
|
|
function GetFileVersionStrW (const file_: UnicodeString) : UnicodeString;
|
|
{$endif}
|
|
|
|
// ***************************************************************
|
|
|
|
// converts a procedure/function to a method
|
|
function ProcedureToMethod (self: TObject; procAddr: pointer) : TMethod;
|
|
|
|
// converts a method to a procedure/function
|
|
// CAUTION: this works only for stdcall methods!!
|
|
// you should free the procedure pointer (FreeMem), when you don't need it anymore
|
|
function MethodToProcedure (self: TObject; methodAddr: pointer; maxParamCount: integer = 32) : pointer; overload;
|
|
function MethodToProcedure (method: TMethod; maxParamCount: integer = 32) : pointer; overload;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
// types for AddMsgHandler/DelMsgHandler
|
|
TMsgHandler = procedure (window: HWND; msg: cardinal; wParam, lParam: NativeInt; var result: NativeInt);
|
|
TMsgHandlerOO = procedure (window: HWND; msg: cardinal; wParam, lParam: NativeInt; var result: NativeInt) of object;
|
|
|
|
// returns the message handler window handle of the specified thread
|
|
// if no such window exists yet (and if threadID = 0) then the window is created
|
|
function MsgHandlerWindow (threadID: cardinal = 0) : cardinal;
|
|
|
|
// add/delete a message handler for the message handler window of the specified thread
|
|
function AddMsgHandler (handler: TMsgHandler; msg: cardinal = 0; threadID: cardinal = 0) : cardinal; overload;
|
|
function AddMsgHandler (handler: TMsgHandlerOO; msg: cardinal = 0; threadID: cardinal = 0) : cardinal; overload;
|
|
function DelMsgHandler (handler: TMsgHandler; msg: cardinal = 0; threadID: cardinal = 0) : boolean; overload;
|
|
function DelMsgHandler (handler: TMsgHandlerOO; msg: cardinal = 0; threadID: cardinal = 0) : boolean; overload;
|
|
|
|
// ***************************************************************
|
|
|
|
const
|
|
// PE header constants
|
|
CENEWHDR = $003C; // offset of new EXE header
|
|
CEMAGIC = $5A4D; // old EXE magic id: 'MZ'
|
|
CPEMAGIC = $4550; // NT portable executable
|
|
IMAGE_NT_OPTIONAL_HDR32_MAGIC = $10b; // 32bit PE file
|
|
{$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR32_MAGIC}
|
|
IMAGE_NT_OPTIONAL_HDR64_MAGIC = $20b; // 64bit PE file
|
|
{$EXTERNALSYM IMAGE_NT_OPTIONAL_HDR64_MAGIC}
|
|
|
|
type
|
|
// PE header types
|
|
TImageImportDirectory = packed record
|
|
HintNameArray : dword;
|
|
TimeDateStamp : dword;
|
|
ForwarderChain : dword;
|
|
Name_ : dword;
|
|
ThunkArray : dword;
|
|
end;
|
|
PImageImportDirectory = ^TImageImportDirectory;
|
|
TImageExportDirectory = packed record
|
|
Characteristics : dword;
|
|
TimeDateStamp : dword;
|
|
MajorVersion : word;
|
|
MinorVersion : word;
|
|
Name_ : dword;
|
|
Base : dword;
|
|
NumberOfFunctions : integer;
|
|
NumberOfNames : integer;
|
|
AddressOfFunctions : dword;
|
|
AddressOfNames : dword;
|
|
AddressOfNameOrdinals : dword;
|
|
end;
|
|
PImageExportDirectory = ^TImageExportDirectory;
|
|
|
|
{$ifndef xe2}
|
|
TImageOptionalHeader64 = packed record
|
|
Magic : word;
|
|
MajorLinkerVersion : byte;
|
|
MinorLinkerVersion : byte;
|
|
SizeOfCode : dword;
|
|
SizeOfInitializedData : dword;
|
|
SizeOfUninitializedData : dword;
|
|
AddressOfEntryPoint : dword;
|
|
BaseOfCode : dword;
|
|
ImageBase : int64;
|
|
SectionAlignment : dword;
|
|
FileAlignment : dword;
|
|
MajorOperatingSystemVersion : word;
|
|
MinorOperatingSystemVersion : word;
|
|
MajorImageVersion : word;
|
|
MinorImageVersion : word;
|
|
MajorSubsystemVersion : word;
|
|
MinorSubsystemVersion : word;
|
|
Win32VersionValue : dword;
|
|
SizeOfImage : dword;
|
|
SizeOfHeaders : dword;
|
|
CheckSum : dword;
|
|
Subsystem : word;
|
|
DllCharacteristics : word;
|
|
SizeOfStackReserve : int64;
|
|
SizeOfStackCommit : int64;
|
|
SizeOfHeapReserve : int64;
|
|
SizeOfHeapCommit : int64;
|
|
LoaderFlags : dword;
|
|
NumberOfRvaAndSizes : dword;
|
|
DataDirectory : array [0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of IMAGE_DATA_DIRECTORY;
|
|
end;
|
|
PImageOptionalHeader64 = ^TImageOptionalHeader64;
|
|
|
|
TImageNtHeaders64 = packed record
|
|
Signature : dword;
|
|
FileHeader : TImageFileHeader;
|
|
OptionalHeader : TImageOptionalHeader64;
|
|
end;
|
|
PImageNtHeaders64 = ^TImageNtHeaders64;
|
|
|
|
TImageOptionalHeader32 = TImageOptionalHeader;
|
|
TImageNtHeaders32 = TImageNtHeaders;
|
|
PImageNtHeaders32 = PImageNtHeaders;
|
|
{$endif}
|
|
|
|
// find out and return whether the dll file is a 64bit dll
|
|
function Is64bitModule (fileName: PWideChar) : bool; stdcall;
|
|
|
|
// does the DLL export an API under the ordinal of 1?
|
|
function DoesModuleExportOrdinal1 (fileName: PWideChar) : boolean; stdcall;
|
|
|
|
// find into which module the specified address belongs (if any)
|
|
function FindModule (addr: pointer; var moduleHandle: HMODULE; var moduleName: AnsiString) : boolean; {$ifdef UnicodeOverloads} overload;
|
|
function FindModule (addr: pointer; var moduleHandle: HMODULE; var moduleName: UnicodeString) : boolean; overload; {$endif}
|
|
|
|
var FindModuleA : function (addr: pointer; var moduleHandle: HMODULE; var moduleName: AnsiString) : boolean = FindModule;
|
|
{$ifdef UnicodeOverloads}
|
|
var FindModuleW : function (addr: pointer; var moduleHandle: HMODULE; var moduleName: UnicodeString) : boolean = FindModule;
|
|
{$else}
|
|
function FindModuleW (addr: pointer; var moduleHandle: HMODULE; var moduleName: UnicodeString) : boolean;
|
|
{$endif}
|
|
|
|
// some low level module image parsing functions
|
|
function GetImageNtHeaders (module: HMODULE) : PImageNtHeaders32;
|
|
function GetImageImportDirectory (module: HMODULE) : PImageImportDirectory;
|
|
function GetImageExportDirectory (module: HMODULE) : PImageExportDirectory;
|
|
|
|
// most of the time GetImageProcAddress is equal to GetProcAddress, except:
|
|
// (1) IAT hooking often hooks GetProcAddress, too, and fakes the result
|
|
// (2) in win9x GetProcAddress refuses to work for ordinal kernel32 APIs
|
|
function GetImageProcAddress (module: HMODULE; const name : AnsiString; doubleCheck: boolean = false) : pointer; overload;
|
|
function GetImageProcAddress (module: HMODULE; index : integer ) : pointer; overload;
|
|
|
|
// this is the opposite of Get(Image)ProcAddress
|
|
function GetImageProcName (module: HMODULE; proc: pointer; unmangle: boolean) : AnsiString;
|
|
function GetImageProcNameW (module: HMODULE; proc: pointer; unmangle: boolean) : UnicodeString;
|
|
var GetImageProcNameA : function (module: HMODULE; proc: pointer; unmangle: boolean) : AnsiString = GetImageProcName;
|
|
|
|
// returns a resource as binary data in a string
|
|
function ResToStr (module: HMODULE; resType: PWideChar; const resName: UnicodeString) : AnsiString;
|
|
|
|
// ***************************************************************
|
|
|
|
// try..except/finally works only if you have SysUtils in your uses clause
|
|
// call this function and it works without SysUtils, too
|
|
procedure InitTryExceptFinally;
|
|
|
|
// ***************************************************************
|
|
|
|
// internal functions, please ignore
|
|
const INVALID_FILE_ATTRIBUTES = DWORD($FFFFFFFF);
|
|
{$EXTERNALSYM INVALID_FILE_ATTRIBUTES}
|
|
function NeedModuleFileMap(module: HMODULE) : pointer;
|
|
function UnmangleA(var publicName, unitName: AnsiString) : boolean;
|
|
function UnmangleW(var publicName, unitName: UnicodeString) : boolean;
|
|
function VirtualToRaw(nh: PImageNtHeaders32; addr: dword) : dword;
|
|
function GetSizeOfImage(nh: PImageNtHeaders32) : dword;
|
|
function TickDif(tick: dword) : dword;
|
|
function IsBadReadPtr2(src: pointer; count: dword) : boolean;
|
|
function IsBadWritePtr2(dst: pointer; count: dword) : boolean;
|
|
var CheckProcAddress : function (var addr: pointer) : boolean = nil;
|
|
NeedModuleFileMapEx : function (module: HMODULE) : pointer = nil;
|
|
HideLeak_ : function (handle: THandle) : boolean = nil;
|
|
IsWine : boolean = false;
|
|
|
|
implementation
|
|
|
|
uses Messages, madStrings;
|
|
|
|
// ***************************************************************
|
|
|
|
var os_ : TOS;
|
|
osReady : boolean = false;
|
|
function OS : TOS;
|
|
const PROCESSOR_ARCHITECTURE_AMD64 = 9;
|
|
VER_NT_WORKSTATION = 1;
|
|
SM_TABLEPC = 86;
|
|
SM_MEDIACENTER = 87;
|
|
SM_STARTER = 88;
|
|
SM_SERVERR2 = 89;
|
|
type TOsVersionInfoExW = packed record
|
|
dwOSVersionInfoSize : dword;
|
|
dwMajorVersion : dword;
|
|
dwMinorVersion : dword;
|
|
dwBuildNumber : dword;
|
|
dwPlatformId : dword;
|
|
szCSDVersion : array [0..127] of WideChar;
|
|
wServicePackMajor : word;
|
|
wServicePackMinor : word;
|
|
wSuiteMask : word;
|
|
wProductType : byte;
|
|
wReserved : byte;
|
|
end;
|
|
var viA : TOsVersionInfoA;
|
|
viW : TOsVersionInfoExW;
|
|
i1 : integer;
|
|
gnsi : procedure (var si: TSystemInfo) stdcall;
|
|
si : TSystemInfo;
|
|
rgv : function (var viW: TOsVersionInfoExW) : HRESULT; stdcall;
|
|
begin
|
|
if (not osReady) or (os_.description = '') then begin
|
|
osReady := true;
|
|
if GetVersion and $80000000 = 0 then begin
|
|
ZeroMemory(@viW, sizeOf(viW));
|
|
viW.dwOSVersionInfoSize := sizeOf(TOsVersionInfoExW);
|
|
rgv := GetProcAddress(GetModuleHandle('ntdll.dll'), 'RtlGetVersion');
|
|
if (@rgv = nil) or (rgv(viW) <> 0) then
|
|
if not GetVersionExW(POsVersionInfo(@viW)^) then begin
|
|
viW.dwOSVersionInfoSize := sizeOf(TOsVersionInfoW);
|
|
GetVersionExW(POsVersionInfo(@viW)^);
|
|
end;
|
|
end else begin
|
|
ZeroMemory(@viA, sizeOf(viA));
|
|
viA.dwOSVersionInfoSize := sizeOf(viA);
|
|
GetVersionExA(viA);
|
|
Move(viA, viW, sizeOf(viA));
|
|
for i1 := low(viA.szCSDVersion) to high(viA.szCSDVersion) do
|
|
viW.szCSDVersion[i1] := WideChar(viA.szCSDVersion[i1]);
|
|
end;
|
|
with os_ do begin
|
|
major := viW.dwMajorVersion;
|
|
minor := viW.dwMinorVersion;
|
|
spStr := viW.szCSDVersion;
|
|
win9x := viW.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS;
|
|
winNt := viW.dwPlatformId = VER_PLATFORM_WIN32_NT;
|
|
if win9x then build := word(viW.dwBuildNumber)
|
|
else build := viW.dwBuildNumber;
|
|
enum := osNone;
|
|
spNo := 0;
|
|
if win9x then begin
|
|
case major of
|
|
0..3 : ;
|
|
4 : case minor of
|
|
00..09 : if build > 1000 then enum := osWin95osr2
|
|
else enum := osWin95;
|
|
10 : if build > 2700 then enum := osWinME
|
|
else if build > 2000 then enum := osWin98se
|
|
else enum := osWin98;
|
|
11..90 : enum := osWinME;
|
|
else enum := osWin9xNew;
|
|
end;
|
|
else enum := osWin9xNew;
|
|
end;
|
|
win9xEnum := enum;
|
|
winNtEnum := osNone;
|
|
end else if winNt then begin
|
|
case major of
|
|
0..3 : enum := osWinNtOld;
|
|
4 : enum := osWinNt4;
|
|
5 : case minor of
|
|
0 : enum := osWin2k;
|
|
1 : enum := osWinXP;
|
|
else begin
|
|
if viW.wProductType = VER_NT_WORKSTATION then
|
|
enum := osWinXP
|
|
else enum := osWin2003;
|
|
end;
|
|
end;
|
|
6 : case minor of
|
|
0 : if viW.wProductType = VER_NT_WORKSTATION then
|
|
enum := osWinVista
|
|
else enum := osWin2008;
|
|
1 : if viW.wProductType = VER_NT_WORKSTATION then
|
|
enum := osWin7
|
|
else enum := osWin2008r2;
|
|
2 : if viW.wProductType = VER_NT_WORKSTATION then
|
|
enum := osWin8
|
|
else enum := osWin2012;
|
|
3 : if viW.wProductType = VER_NT_WORKSTATION then
|
|
enum := osWin81
|
|
else enum := osWin2012r2;
|
|
else enum := osWinNtNew;
|
|
end;
|
|
10 : if viW.wProductType = VER_NT_WORKSTATION then begin
|
|
if build >= 22000 then
|
|
enum := osWin11
|
|
else
|
|
enum := osWin10;
|
|
end else
|
|
if build >= 17763 then
|
|
enum := osWin2019
|
|
else
|
|
enum := osWin2016;
|
|
else enum := osWinNtNew;
|
|
end;
|
|
win9xEnum := osNone;
|
|
winNtEnum := enum;
|
|
if viW.dwOSVersionInfoSize >= sizeOf(TOsVersionInfoExW) then
|
|
spNo := viW.wServicePackMajor
|
|
else
|
|
if Length(spStr) >= 14 then
|
|
spNo := StrToIntExW(false, @spStr[14], Length(spStr) - 13);
|
|
gnsi := GetProcAddress(GetModuleHandle(kernel32), 'GetNativeSystemInfo');
|
|
if @gnsi <> nil then begin
|
|
ZeroMemory(@si, sizeOf(si));
|
|
gnsi(si);
|
|
x64 := si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64;
|
|
end;
|
|
end;
|
|
description := UnicodeString(AnsiString(COsDescr[enum]));
|
|
if winNt then begin
|
|
if GetSystemMetrics(SM_SERVERR2) <> 0 then
|
|
description := description + ' R2';
|
|
if GetSystemMetrics(SM_STARTER) <> 0 then
|
|
description := description + ' Starter';
|
|
if (enum < osWinVista) and (GetSystemMetrics(SM_MEDIACENTER) <> 0) then
|
|
description := description + ' Media Center';
|
|
if x64 then
|
|
description := description + ' x64';
|
|
if spStr <> '' then
|
|
description := description + ' ' + spStr;
|
|
end;
|
|
end;
|
|
end;
|
|
result := os_;
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
{$ifndef win64}
|
|
|
|
//this was nice, but unfortunately doesn't work in BCB:
|
|
|
|
//function LoadLibrary16 (libraryName : PAnsiChar ) : dword; stdcall; external kernel32 index 35;
|
|
//function FreeLibrary16 (hInstance : dword ) : integer; stdcall; external kernel32 index 36;
|
|
//function GetProcAddress16 (hinstance : dword; procName: PAnsiChar) : pointer; stdcall; external kernel32 index 37;
|
|
|
|
// so we have to do it the hard way:
|
|
|
|
var LoadLibrary16 : function (libraryName : PAnsiChar ) : dword stdcall = nil;
|
|
FreeLibrary16 : function (hInstance : dword ) : integer stdcall = nil;
|
|
GetProcAddress16 : function (hinstance : dword; procName: PAnsiChar) : pointer stdcall = nil;
|
|
|
|
function GetFreeSystemResources(resource: word) : word;
|
|
var thunkTrash : array [0..$3f] of byte;
|
|
user16 : dword;
|
|
gfsr : pointer;
|
|
qtt : pointer;
|
|
dll : dword;
|
|
begin
|
|
result := 0;
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
if @LoadLibrary16 = nil then begin
|
|
dll := GetModuleHandle(kernel32);
|
|
LoadLibrary16 := GetImageProcAddress(dll, 35);
|
|
FreeLibrary16 := GetImageProcAddress(dll, 36);
|
|
GetProcAddress16 := GetImageProcAddress(dll, 37);
|
|
end;
|
|
if @LoadLibrary16 <> nil then begin
|
|
user16 := LoadLibrary16('user.exe');
|
|
if user16 <> 0 then begin
|
|
thunkTrash[0] := 0;
|
|
gfsr := GetProcAddress16(user16, 'GetFreeSystemResources');
|
|
qtt := GetProcAddress(GetModuleHandle(kernel32), 'QT_Thunk');
|
|
if (gfsr <> nil) and (qtt <> nil) then
|
|
asm
|
|
push resource
|
|
mov edx, gfsr
|
|
call qtt
|
|
mov result, ax
|
|
end;
|
|
FreeLibrary16(user16);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
// ***************************************************************
|
|
|
|
function ExtractFileDriveA(const fileName: AnsiString) : AnsiString;
|
|
var i1 : integer;
|
|
begin
|
|
result := '';
|
|
if Length(fileName) >= 2 then
|
|
if (fileName[1] = '\') and (fileName[2] = '\') then begin
|
|
i1 := PosStrA('\', fileName, 3);
|
|
if (i1 > 0) and (i1 < Length(fileName)) then begin
|
|
i1 := PosStrA('\', fileName, i1 + 1);
|
|
if i1 > 0 then
|
|
result := Copy(fileName, 1, i1)
|
|
else
|
|
result := fileName;
|
|
end;
|
|
end else
|
|
if fileName[2] = ':' then
|
|
result := Copy(fileName, 1, 3);
|
|
end;
|
|
|
|
function GetShortFileName(fileName: AnsiString) : AnsiString;
|
|
var c1, c2 : dword;
|
|
wfd : TWin32FindDataA;
|
|
fh : THandle;
|
|
begin
|
|
result := '';
|
|
if (fileName <> '') and (fileName[Length(fileName)] = '\') then
|
|
Delete(fileName, Length(fileName), 1);
|
|
c2 := Length(ExtractFileDriveA(fileName));
|
|
repeat
|
|
c1 := PosStrA('\', fileName, maxInt, 1);
|
|
if (c2 = 0) or (c1 < c2) then begin
|
|
result := fileName + '\' + result;
|
|
break;
|
|
end;
|
|
{$ifdef d6}
|
|
if (PosStrA('*', fileName, c1 + 1) = 0) and (PosStrA('?', fileName, c1 + 1) = 0) then begin
|
|
{$else}
|
|
// Delphi 4 compiler needs it this way, or else we get internal error C11567
|
|
if (PosStr('*', fileName, c1 + 1) = 0) and (PosStr('?', fileName, c1 + 1) = 0) then begin
|
|
{$endif}
|
|
fh := FindFirstFileA(PAnsiChar(fileName), wfd);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
windows.FindClose(fh);
|
|
if wfd.cAlternateFileName[0] <> #0 then
|
|
result := AnsiString(wfd.cAlternateFileName) + '\' + result
|
|
else
|
|
result := AnsiString(wfd.cFileName ) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
Delete(fileName, c1, maxInt);
|
|
until (c1 = 0) or (fileName = '');
|
|
if (result <> '') and (result[Length(result)] = '\') then
|
|
Delete(result, Length(result), 1);
|
|
end;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
function GetShortFileName(fileName: UnicodeString) : UnicodeString;
|
|
{$else}
|
|
function GetShortFileNameW(fileName: UnicodeString) : UnicodeString;
|
|
{$endif}
|
|
var c1, c2 : cardinal;
|
|
wfd : TWin32FindDataW;
|
|
fh : THandle;
|
|
begin
|
|
result := '';
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
result := UnicodeString(GetShortFileName(AnsiString(fileName)));
|
|
exit;
|
|
end;
|
|
if (fileName <> '') and (fileName[Length(fileName)] = '\') then
|
|
Delete(fileName, Length(fileName), 1);
|
|
c2 := Length(ExtractFileDriveW(fileName));
|
|
repeat
|
|
c1 := PosStrW('\', fileName, maxInt, 1);
|
|
if (c2 = 0) or (c1 < c2) then begin
|
|
result := fileName + '\' + result;
|
|
break;
|
|
end;
|
|
if (PosStrW('*', fileName, c1 + 1) = 0) and (PosStrW('?', fileName, c1 + 1) = 0) then begin
|
|
fh := FindFirstFileW(PWideChar(fileName), wfd);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
windows.FindClose(fh);
|
|
if wfd.cAlternateFileName[0] <> #0 then
|
|
result := UnicodeString(wfd.cAlternateFileName) + '\' + result
|
|
else
|
|
result := UnicodeString(wfd.cFileName ) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
Delete(fileName, c1, maxInt);
|
|
until (c1 = 0) or (fileName = '');
|
|
if (result <> '') and (result[Length(result)] = '\') then
|
|
Delete(result, Length(result), 1);
|
|
end;
|
|
|
|
function GetLongFileName(fileName: AnsiString) : AnsiString;
|
|
var c1, c2 : cardinal;
|
|
wfd : TWin32FindDataA;
|
|
fh : THandle;
|
|
begin
|
|
result := '';
|
|
if (fileName <> '') and (fileName[Length(fileName)] = '\') then
|
|
Delete(fileName, Length(fileName), 1);
|
|
c2 := Length(ExtractFileDriveA(fileName));
|
|
repeat
|
|
c1 := PosStrA('\', fileName, maxInt, 1);
|
|
if (c2 = 0) or (c1 < c2) then begin
|
|
result := fileName + '\' + result;
|
|
break;
|
|
end;
|
|
{$ifdef d6}
|
|
if (PosStrA('~', fileName, c1 + 1) > 0) and (PosStrA('*', fileName, c1 + 1) = 0) and (PosStrA('?', fileName, c1 + 1) = 0) then begin
|
|
{$else}
|
|
// Delphi 4 compiler needs it this way, or else we get internal error C11567
|
|
if (PosStr('~', fileName, c1 + 1) > 0) and (PosStr('*', fileName, c1 + 1) = 0) and (PosStr('?', fileName, c1 + 1) = 0) then begin
|
|
{$endif}
|
|
fh := FindFirstFileA(PAnsiChar(fileName), wfd);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
windows.FindClose(fh);
|
|
result := AnsiString(wfd.cfileName) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
Delete(fileName, c1, maxInt);
|
|
until (c1 = 0) or (fileName = '');
|
|
if (result <> '') and (result[Length(result)] = '\') then
|
|
Delete(result, Length(result), 1);
|
|
end;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
function GetLongFileName(fileName: UnicodeString) : UnicodeString;
|
|
{$else}
|
|
function GetLongFileNameW(fileName: UnicodeString) : UnicodeString;
|
|
{$endif}
|
|
var c1, c2 : cardinal;
|
|
wfd : TWin32FindDataW;
|
|
fh : THandle;
|
|
begin
|
|
result := '';
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
result := UnicodeString(GetLongFileNameA(AnsiString(fileName)));
|
|
exit;
|
|
end;
|
|
if (fileName <> '') and (fileName[Length(fileName)] = '\') then
|
|
Delete(fileName, Length(fileName), 1);
|
|
c2 := Length(ExtractFileDriveW(fileName));
|
|
repeat
|
|
c1 := PosStrW('\', fileName, maxInt, 1);
|
|
if (c2 = 0) or (c1 < c2) then begin
|
|
result := fileName + '\' + result;
|
|
break;
|
|
end;
|
|
if (PosStrW('~', fileName, c1 + 1) > 0) and (PosStrW('*', fileName, c1 + 1) = 0) and (PosStrW('?', fileName, c1 + 1) = 0) then begin
|
|
fh := FindFirstFileW(PWideChar(fileName), wfd);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
windows.FindClose(fh);
|
|
result := UnicodeString(wfd.cfileName) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
end else
|
|
result := Copy(fileName, c1 + 1, maxInt) + '\' + result;
|
|
Delete(fileName, c1, maxInt);
|
|
until (c1 = 0) or (fileName = '');
|
|
if (result <> '') and (result[Length(result)] = '\') then
|
|
Delete(result, Length(result), 1);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
function GetFileVersion(const file_: AnsiString) : int64;
|
|
var len, hnd : dword;
|
|
buf : AnsiString;
|
|
pfi : PVsFixedFileInfo;
|
|
begin
|
|
result := 0;
|
|
len := GetFileVersionInfoSizeA(PAnsiChar(file_), hnd);
|
|
if len <> 0 then begin
|
|
SetLength(buf, len);
|
|
if GetFileVersionInfoA(PAnsiChar(file_), hnd, len, pointer(buf)) and
|
|
VerQueryValueA(pointer(buf), '\', pointer(pfi), len) then
|
|
result := int64(pfi^.dwFileVersionMS) shl 32 + int64(pfi^.dwFileVersionLS);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
function GetFileVersion(const file_: UnicodeString) : int64;
|
|
{$else}
|
|
function GetFileVersionW(const file_: UnicodeString) : int64;
|
|
{$endif}
|
|
var len, hnd : dword;
|
|
buf : AnsiString;
|
|
pfi : PVsFixedFileInfo;
|
|
begin
|
|
result := 0;
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
result := GetFileVersionA(AnsiString(file_));
|
|
exit;
|
|
end;
|
|
len := GetFileVersionInfoSizeW(PWideChar(file_), hnd);
|
|
if len <> 0 then begin
|
|
SetLength(buf, len);
|
|
if GetFileVersionInfoW(PWideChar(file_), hnd, len, pointer(buf)) and
|
|
VerQueryValueW(pointer(buf), '\', pointer(pfi), len) then
|
|
result := int64(pfi^.dwFileVersionMS) shl 32 + int64(pfi^.dwFileVersionLS);
|
|
end;
|
|
end;
|
|
|
|
function FileVersionToStr(version: int64) : AnsiString;
|
|
begin
|
|
result := IntToStrExA( version shr 48 ) + '.' +
|
|
IntToStrExA((version shr 32) and $FFFF) + '.' +
|
|
IntToStrExA((version shr 16) and $FFFF) + '.' +
|
|
IntToStrExA( version and $FFFF);
|
|
end;
|
|
|
|
function FileVersionToStrW(version: int64) : UnicodeString;
|
|
begin
|
|
result := IntToStrExW( version shr 48 ) + '.' +
|
|
IntToStrExW((version shr 32) and $FFFF) + '.' +
|
|
IntToStrExW((version shr 16) and $FFFF) + '.' +
|
|
IntToStrExW( version and $FFFF);
|
|
end;
|
|
|
|
function GetFileVersionStr(const file_: AnsiString) : AnsiString;
|
|
var len, hnd : dword;
|
|
buf : AnsiString;
|
|
pfi : PVsFixedFileInfo;
|
|
trans : ^integer;
|
|
value : PAnsiChar;
|
|
begin
|
|
result := '';
|
|
len := GetFileVersionInfoSizeA(PAnsiChar(file_), hnd);
|
|
if len <> 0 then begin
|
|
SetLength(buf, len);
|
|
if GetFileVersionInfoA(PAnsiChar(file_), hnd, len, pointer(buf)) then
|
|
if VerQueryValueA(pointer(buf), '\', pointer(pfi), len) and ((pfi^.dwFileVersionMS <> 0) or (pfi^.dwFileVersionLS <> 0)) then
|
|
result := FileVersionToStrA(int64(pfi^.dwFileVersionMS) shl 32 + int64(pfi^.dwFileVersionLS))
|
|
else
|
|
if VerQueryValueA(pointer(buf), '\VarFileInfo\Translation', pointer(trans), len) and (trans <> nil) and
|
|
VerQueryValueA(Pointer(buf), PAnsiChar('\StringFileInfo\' + Copy(IntToHexExA(MakeLong(HiWord(trans^), LoWord(trans^)), 8), 2, maxInt) + '\FileVersion'), pointer(value), len) then
|
|
result := RetTrimStrA(value);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
function GetFileVersionStr(const file_: UnicodeString) : UnicodeString;
|
|
{$else}
|
|
function GetFileVersionStrW(const file_: UnicodeString) : UnicodeString;
|
|
{$endif}
|
|
var len, hnd : dword;
|
|
buf : UnicodeString;
|
|
pfi : PVsFixedFileInfo;
|
|
trans : ^integer;
|
|
value : PWideChar;
|
|
begin
|
|
result := '';
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
result := UnicodeString(GetFileVersionStrA(AnsiString(file_)));
|
|
exit;
|
|
end;
|
|
len := GetFileVersionInfoSizeW(PWideChar(file_), hnd);
|
|
if len <> 0 then begin
|
|
SetLength(buf, len);
|
|
if GetFileVersionInfoW(PWideChar(file_), hnd, len, pointer(buf)) then
|
|
if VerQueryValueW(pointer(buf), '\', pointer(pfi), len) and ((pfi^.dwFileVersionMS <> 0) or (pfi^.dwFileVersionLS <> 0)) then
|
|
result := UnicodeString(FileVersionToStrW(int64(pfi^.dwFileVersionMS) shl 32 + int64(pfi^.dwFileVersionLS)))
|
|
else
|
|
if VerQueryValueW(pointer(buf), '\VarFileInfo\Translation', pointer(trans), len) and (trans <> nil) and
|
|
VerQueryValueW(pointer(buf), PWideChar(WideString('\StringFileInfo\' + Copy(IntToHexExW(MakeLong(HiWord(trans^), LoWord(trans^)), 8), 2, maxInt) + '\FileVersion')), pointer(value), len) then
|
|
result := RetTrimStrW(value);
|
|
end;
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
{$ifdef win64}
|
|
|
|
function MethodToProcedure(self: TObject; methodAddr: pointer; maxParamCount: integer = 32) : pointer;
|
|
const
|
|
AsmArr1 : array [0..79] of byte =
|
|
($48, $81, $ec, $00, $00, $00, $00, // sub rsp, $118
|
|
$48, $89, $84, $24, $00, $00, $00, $00, // mov [rsp+$110], rax
|
|
$48, $8b, $84, $24, $00, $00, $00, $00, // mov rax, [rsp+$120] // read 1st original stack parameter
|
|
$48, $89, $44, $24, $08, // mov [rsp+8], rax // store as 2nd new stack parameter
|
|
$48, $8b, $84, $24, $00, $00, $00, $00, // mov rax, [rsp+$128] // read 2nd original stack parameter
|
|
$48, $89, $44, $24, $10, // mov [rsp+$10], rax // store as 3rd new stack parameter
|
|
$48, $8b, $84, $24, $00, $00, $00, $00, // mov rax, [rsp+$130] // read 3rd original stack parameter
|
|
$48, $89, $44, $24, $18, // mov [rsp+$18], rax // store as 4th new stack parameter
|
|
$4c, $89, $4c, $24, $20, // mov [rsp+$20], r9 // store 4th original register parameter as 5th new stack parameter
|
|
$4d, $89, $c1, // mov r9, r8 // cycle the register parameters (rcx -> rdx -> r8 -> r9)
|
|
$49, $89, $d0, // mov r8, rdx
|
|
$48, $89, $ca, // mov rdx, rcx
|
|
$66, $0f, $6f, $da, // movdqa xmm3, xmm2 // cycle the register parameters (xmm0 -> xmm1 -> xmm2 -> xmm3)
|
|
$66, $0f, $6f, $d1, // movdqa xmm2, xmm1
|
|
$66, $0f, $6f, $c8); // movdqa xmm1, xmm0
|
|
AsmArr2 : array [0..15] of byte =
|
|
($48, $8b, $84, $24, $00, $00, $00, $00, // mov rax, [rsp+$140]
|
|
$48, $89, $84, $24, $00, $00, $00, $00); // mov [rsp+$28], rax
|
|
AsmArr3 : array [0..54] of byte =
|
|
($48, $8b, $84, $24, $00, $00, $00, $00, // mov rax, [rsp+$110]
|
|
$48, $b9, $00, $00, $00, $00, $00, $00, $00, $00, // mov rcx, methodAddr
|
|
$48, $89, $8c, $24, $00, $00, $00, $00, // mov [rsp+$110], rcx
|
|
$48, $b9, $00, $00, $00, $00, $00, $00, $00, $00, // mov rcx, self
|
|
$48, $89, $0c, $24, // mov [rsp], rcx // store "self" as 1st new stack parameter
|
|
$ff, $94, $24, $00, $00, $00, $00, // call [rsp+$110]
|
|
$48, $81, $c4, $00, $00, $00, $00, // add rsp, $118
|
|
$c3); // ret
|
|
|
|
var stackSpace : integer;
|
|
s1, s2 : AnsiString;
|
|
pos : integer;
|
|
i1 : integer;
|
|
op : dword;
|
|
begin
|
|
if maxParamCount < 4 then
|
|
maxParamCount := 4;
|
|
if odd(maxParamCount) then
|
|
stackSpace := (maxParamCount + 2) * 8 // parameters + self + localVar
|
|
else
|
|
stackSpace := (maxParamCount + 3) * 8; // parameters + self + localVar + alignment
|
|
SetString(s1, PAnsiChar(@(AsmArr1[0])), 80);
|
|
integer(pointer(@s1[ 4])^) := stackSpace;
|
|
integer(pointer(@s1[12])^) := stackSpace - $8;
|
|
integer(pointer(@s1[20])^) := stackSpace + $8;
|
|
integer(pointer(@s1[33])^) := stackSpace + $10;
|
|
integer(pointer(@s1[46])^) := stackSpace + $18;
|
|
pos := Length(s1) + 1;
|
|
SetLength(s1, Length(s1) + (maxParamCount - 4) * 16);
|
|
SetString(s2, PAnsiChar(@(AsmArr2[0])), 16);
|
|
for i1 := 1 to maxParamCount - 4 do begin
|
|
integer(pointer(@s2[ 5])^) := $20 + i1 * 8 + stackSpace;
|
|
integer(pointer(@s2[13])^) := $20 + i1 * 8;
|
|
Move(s2[1], s1[pos], Length(s2));
|
|
inc(pos, Length(s2));
|
|
end;
|
|
SetString(s2, PAnsiChar(@(AsmArr3[0])), 55);
|
|
integer(pointer(@s2[ 5])^) := stackSpace - $8;
|
|
pointer(pointer(@s2[11])^) := methodAddr;
|
|
integer(pointer(@s2[23])^) := stackSpace - $8;
|
|
pointer(pointer(@s2[29])^) := self;
|
|
integer(pointer(@s2[44])^) := stackSpace - $8;
|
|
integer(pointer(@s2[51])^) := stackSpace;
|
|
s1 := s1 + s2;
|
|
result := VirtualAlloc(nil, Length(s1), MEM_COMMIT, PAGE_EXECUTE_READWRITE);
|
|
Move(s1[1], result^, Length(s1));
|
|
VirtualProtect(nil, Length(s1), PAGE_EXECUTE_READ, @op);
|
|
end;
|
|
|
|
{$else}
|
|
|
|
function MethodToProcedure(self: TObject; methodAddr: pointer; maxParamCount: integer = 32) : pointer;
|
|
type
|
|
TMethodToProc = packed record
|
|
popEax : byte; // $58 pop EAX
|
|
pushSelf : record // push self
|
|
opcode : byte; // $B8
|
|
self : pointer; // self
|
|
end;
|
|
pushEax : byte; // $50 push EAX
|
|
jump : record // jmp [target]
|
|
opcode : byte; // $FF
|
|
modRm : byte; // $25
|
|
pTarget : ^pointer; // @target
|
|
target : pointer; // @MethodAddr
|
|
end;
|
|
end;
|
|
var mtp : ^TMethodToProc absolute result;
|
|
op : dword;
|
|
begin
|
|
mtp := VirtualAlloc(nil, sizeOf(mtp^), MEM_COMMIT, PAGE_EXECUTE_READWRITE);
|
|
with mtp^ do begin
|
|
popEax := $58;
|
|
pushSelf.opcode := $68;
|
|
pushSelf.self := self;
|
|
pushEax := $50;
|
|
jump.opcode := $FF;
|
|
jump.modRm := $25;
|
|
jump.pTarget := @jump.target;
|
|
jump.target := methodAddr;
|
|
end;
|
|
VirtualProtect(nil, sizeOf(mtp^), PAGE_EXECUTE_READ, @op);
|
|
end;
|
|
|
|
{$endif}
|
|
|
|
function MethodToProcedure(method: TMethod; maxParamCount: integer = 32) : pointer;
|
|
begin
|
|
result := MethodToProcedure(TObject(method.data), method.code);
|
|
end;
|
|
|
|
function ProcedureToMethod(self: TObject; procAddr: pointer) : TMethod;
|
|
begin
|
|
result.Data := self;
|
|
result.Code := procAddr;
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
type
|
|
TMsgHandlers = array of record
|
|
message : cardinal;
|
|
handler : TMsgHandler;
|
|
handlerOO : TMsgHandlerOO;
|
|
end;
|
|
|
|
var
|
|
MsgHandlerMutex : THandle = 0;
|
|
MsgHandlerWindows : array of record
|
|
threadID : cardinal;
|
|
window : HWND;
|
|
handlers : TMsgHandlers;
|
|
classAtom : word;
|
|
end;
|
|
|
|
function MsgHandlerWindowProc(window: HWND; msg: cardinal; wParam, lParam: NativeInt) : NativeInt; stdcall;
|
|
var i1 : integer;
|
|
mh : TMsgHandlers;
|
|
begin
|
|
mh := nil;
|
|
if IsWindowUnicode(window) then
|
|
result := DefWindowProcW(window, msg, wParam, lParam)
|
|
else
|
|
result := DefWindowProcA(window, msg, wParam, lParam);
|
|
if (msg in [WM_QUERYENDSESSION, WM_QUIT, WM_SYSCOLORCHANGE, WM_ENDSESSION, WM_SYSTEMERROR,
|
|
WM_WININICHANGE, WM_DEVMODECHANGE, WM_ACTIVATEAPP, WM_FONTCHANGE, WM_TIMECHANGE,
|
|
WM_SPOOLERSTATUS, WM_COMPACTING, WM_POWER, WM_INPUTLANGCHANGEREQUEST, WM_INPUTLANGCHANGE,
|
|
WM_USERCHANGED, WM_DISPLAYCHANGE, WM_COPYDATA]) or (msg >= WM_POWERBROADCAST) then begin
|
|
WaitForSingleObject(MsgHandlerMutex, INFINITE);
|
|
try
|
|
for i1 := 0 to high(MsgHandlerWindows) do
|
|
if MsgHandlerWindows[i1].window = window then begin
|
|
mh := Copy(MsgHandlerWindows[i1].handlers);
|
|
break;
|
|
end;
|
|
finally ReleaseMutex(MsgHandlerMutex) end;
|
|
for i1 := 0 to high(mh) do
|
|
if mh[i1].message = msg then
|
|
if @mh[i1].handler <> nil then
|
|
mh[i1].handler (window, msg, wParam, lParam, result)
|
|
else mh[i1].handlerOO(window, msg, wParam, lParam, result);
|
|
end;
|
|
end;
|
|
|
|
function MsgHandlerWindow(threadID: cardinal = 0) : cardinal;
|
|
const CMadToolsMsgHandlerWindow : PAnsiChar = 'madToolsMsgHandlerWindow';
|
|
var wndClass : TWndClassA;
|
|
mutex : THandle;
|
|
i1 : integer;
|
|
s1 : AnsiString;
|
|
atom : word;
|
|
begin
|
|
result := 0;
|
|
if threadID = 0 then
|
|
threadID := GetCurrentThreadID;
|
|
s1 := IntToHexExA(GetCurrentThreadID) + IntToHexExA(NativeUInt(@MsgHandlerWindow));
|
|
if MsgHandlerMutex = 0 then begin
|
|
mutex := CreateMutexA(nil, false, nil);
|
|
if mutex <> 0 then begin
|
|
if @HideLeak_ <> nil then
|
|
HideLeak_(mutex);
|
|
WaitForSingleObject(mutex, INFINITE);
|
|
if MsgHandlerMutex = 0 then
|
|
MsgHandlerMutex := mutex
|
|
else
|
|
CloseHandle(mutex);
|
|
end;
|
|
end else
|
|
WaitForSingleObject(MsgHandlerMutex, INFINITE);
|
|
try
|
|
for i1 := 0 to high(MsgHandlerWindows) do
|
|
if MsgHandlerWindows[i1].threadID = threadID then begin
|
|
result := MsgHandlerWindows[i1].window;
|
|
break;
|
|
end;
|
|
finally ReleaseMutex(MsgHandlerMutex) end;
|
|
if (result = 0) and (threadID = GetCurrentThreadID) then begin
|
|
ZeroMemory(@wndClass, sizeOf(wndClass));
|
|
wndClass.lpfnWndProc := @MsgHandlerWindowProc;
|
|
wndClass.hInstance := GetModuleHandle(nil);
|
|
wndClass.lpszClassName := PAnsiChar(CMadToolsMsgHandlerWindow + s1);
|
|
atom := windows.RegisterClassA(wndClass);
|
|
result := CreateWindowExA(WS_EX_TOOLWINDOW, PAnsiChar(atom), '', WS_POPUP, 0, 0, 0, 0, 0, 0, wndClass.hInstance, nil);
|
|
if result <> 0 then begin
|
|
WaitForSingleObject(MsgHandlerMutex, INFINITE);
|
|
try
|
|
i1 := Length(MsgHandlerWindows);
|
|
SetLength(MsgHandlerWindows, i1 + 1);
|
|
MsgHandlerWindows[i1].threadID := threadID;
|
|
MsgHandlerWindows[i1].window := result;
|
|
MsgHandlerWindows[i1].classAtom := atom;
|
|
finally ReleaseMutex(MsgHandlerMutex) end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure AllowWindowMessage(wnd: HWND; msg: dword);
|
|
// tell User Interface Privilege Isolation that we want to receive this message
|
|
var cwmf : function (msg, flag: dword) : bool; stdcall;
|
|
cwmfex : function (wnd: HWND; msg, action: dword; extendedResult: pointer) : bool; stdcall;
|
|
begin
|
|
cwmfex := GetProcAddress(GetModuleHandle(user32), 'ChangeWindowMessageFilterEx');
|
|
if @cwmfex <> nil then
|
|
cwmfex(wnd, msg, 1, nil)
|
|
else begin
|
|
cwmf := GetProcAddress(GetModuleHandle(user32), 'ChangeWindowMessageFilter');
|
|
if @cwmf <> nil then
|
|
cwmf(msg, 1);
|
|
end;
|
|
end;
|
|
|
|
function AddMsgHandler_(handler: TMsgHandler; handlerOO: TMsgHandlerOO; msg, threadID: cardinal) : cardinal;
|
|
var i1, i2 : integer;
|
|
b1 : boolean;
|
|
window : HWND;
|
|
begin
|
|
result := 0;
|
|
window := MsgHandlerWindow(threadID);
|
|
if window <> 0 then begin
|
|
WaitForSingleObject(MsgHandlerMutex, INFINITE);
|
|
try
|
|
for i1 := 0 to high(MsgHandlerWindows) do
|
|
if MsgHandlerWindows[i1].window = window then
|
|
with MsgHandlerWindows[i1] do begin
|
|
if msg = 0 then begin
|
|
msg := WM_USER;
|
|
repeat
|
|
b1 := true;
|
|
for i2 := 0 to high(handlers) do
|
|
if handlers[i2].message = msg then begin
|
|
b1 := false;
|
|
inc(msg);
|
|
break;
|
|
end;
|
|
until b1;
|
|
end else
|
|
for i2 := 0 to high(handlers) do
|
|
if (handlers[i2].message = msg) and
|
|
( @handlers[i2].handler = @handler ) and
|
|
(TMethod(handlers[i2].handlerOO).code = TMethod(handlerOO).code) and
|
|
(TMethod(handlers[i2].handlerOO).data = TMethod(handlerOO).data) then
|
|
exit;
|
|
i2 := Length(handlers);
|
|
SetLength(handlers, i2 + 1);
|
|
handlers[i2].message := msg;
|
|
handlers[i2].handler := handler;
|
|
handlers[i2].handlerOO := handlerOO;
|
|
result := msg;
|
|
AllowWindowMessage(window, msg);
|
|
break;
|
|
end;
|
|
finally ReleaseMutex(MsgHandlerMutex) end;
|
|
end;
|
|
end;
|
|
|
|
function AddMsgHandler(handler: TMsgHandler; msg: cardinal = 0; threadID: cardinal = 0) : cardinal;
|
|
begin
|
|
result := AddMsgHandler_(handler, nil, msg, threadID);
|
|
end;
|
|
|
|
function AddMsgHandler(handler: TMsgHandlerOO; msg: cardinal = 0; threadID: cardinal = 0) : cardinal;
|
|
begin
|
|
result := AddMsgHandler_(nil, handler, msg, threadID);
|
|
end;
|
|
|
|
function DelMsgHandler_(handler: TMsgHandler; handlerOO: TMsgHandlerOO; msg, threadID: cardinal) : boolean;
|
|
var i1, i2 : integer;
|
|
w1 : HWND;
|
|
a1 : word;
|
|
begin
|
|
result := false;
|
|
if MsgHandlerMutex <> 0 then begin
|
|
if threadID = 0 then
|
|
threadID := GetCurrentThreadID;
|
|
w1 := 0;
|
|
a1 := 0;
|
|
WaitForSingleObject(MsgHandlerMutex, INFINITE);
|
|
try
|
|
for i1 := 0 to high(MsgHandlerWindows) do
|
|
if MsgHandlerWindows[i1].threadID = threadID then
|
|
with MsgHandlerWindows[i1] do begin
|
|
for i2 := high(handlers) downto 0 do
|
|
if ( (msg = 0) or (handlers[i2].message = msg) ) and
|
|
( @handlers[i2].handler = @handler ) and
|
|
(TMethod(handlers[i2].handlerOO).code = TMethod(handlerOO).code) and
|
|
(TMethod(handlers[i2].handlerOO).data = TMethod(handlerOO).data) then begin
|
|
handlers[i2] := handlers[high(handlers)];
|
|
SetLength(handlers, high(handlers));
|
|
end;
|
|
if (handlers = nil) and IsWindow(window) then begin
|
|
w1 := window;
|
|
a1 := MsgHandlerWindows[i1].classAtom;
|
|
MsgHandlerWindows[i1] := MsgHandlerWindows[high(MsgHandlerWindows)];
|
|
SetLength(MsgHandlerWindows, high(MsgHandlerWindows));
|
|
end;
|
|
break;
|
|
end;
|
|
finally ReleaseMutex(MsgHandlerMutex) end;
|
|
if w1 <> 0 then
|
|
if threadID = GetCurrentThreadID then begin
|
|
DestroyWindow(w1);
|
|
UnregisterClassA(PAnsiChar(a1), GetModuleHandle(nil));
|
|
end else
|
|
PostMessage(w1, WM_CLOSE, 0, 0);
|
|
end;
|
|
end;
|
|
|
|
function DelMsgHandler(handler: TMsgHandler; msg: cardinal = 0; threadID: cardinal = 0) : boolean;
|
|
begin
|
|
result := DelMsgHandler_(handler, nil, msg, threadID);
|
|
end;
|
|
|
|
function DelMsgHandler(handler: TMsgHandlerOO; msg: cardinal = 0; threadID: cardinal = 0) : boolean;
|
|
begin
|
|
result := DelMsgHandler_(nil, handler, msg, threadID);
|
|
end;
|
|
|
|
procedure FinalMsgHandler;
|
|
var mutex : THandle;
|
|
begin
|
|
mutex := MsgHandlerMutex;
|
|
MsgHandlerMutex := 0;
|
|
if mutex <> 0 then
|
|
CloseHandle(mutex);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
function FindModule(addr: pointer; var moduleHandle: HMODULE; var moduleName: AnsiString) : boolean;
|
|
var mbi : TMemoryBasicInformation;
|
|
arrCh : array [0..MAX_PATH] of WideChar;
|
|
begin
|
|
result := (VirtualQuery(addr, mbi, sizeOf(mbi)) = sizeOf(mbi)) and
|
|
(mbi.State = MEM_COMMIT) and (mbi.AllocationBase <> nil);
|
|
if result then begin
|
|
if GetVersion and $80000000 = 0 then
|
|
result := GetModuleFileNameW(HMODULE(mbi.AllocationBase), arrCh, MAX_PATH) <> 0
|
|
else
|
|
result := GetModuleFileNameA(HMODULE(mbi.AllocationBase), pointer(@arrCh), MAX_PATH) <> 0;
|
|
if result then begin
|
|
moduleHandle := HMODULE(mbi.AllocationBase);
|
|
if GetVersion and $80000000 = 0 then
|
|
moduleName := WideToAnsiEx(arrCh)
|
|
else
|
|
moduleName := PAnsiChar(@arrCh);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$ifdef UnicodeOverloads}
|
|
function FindModule(addr: pointer; var moduleHandle: HMODULE; var moduleName: UnicodeString) : boolean;
|
|
{$else}
|
|
function FindModuleW(addr: pointer; var moduleHandle: HMODULE; var moduleName: UnicodeString) : boolean;
|
|
{$endif}
|
|
var mbi : TMemoryBasicInformation;
|
|
arrCh : array [0..MAX_PATH] of WideChar;
|
|
begin
|
|
result := (VirtualQuery(addr, mbi, sizeOf(mbi)) = sizeOf(mbi)) and
|
|
(mbi.State = MEM_COMMIT) and (mbi.AllocationBase <> nil);
|
|
if result then begin
|
|
if GetVersion and $80000000 = 0 then
|
|
result := GetModuleFileNameW(HMODULE(mbi.AllocationBase), arrCh, MAX_PATH) <> 0
|
|
else
|
|
result := GetModuleFileNameA(HMODULE(mbi.AllocationBase), pointer(@arrCh), MAX_PATH) <> 0;
|
|
if result then begin
|
|
moduleHandle := HMODULE(mbi.AllocationBase);
|
|
if GetVersion and $80000000 = 0 then
|
|
moduleName := arrCh
|
|
else
|
|
moduleName := UnicodeString(AnsiString(PAnsiChar(@arrCh)));
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetImageNtHeaders(module: HMODULE) : PImageNtHeaders32;
|
|
begin
|
|
result := nil;
|
|
try
|
|
if (not IsBadReadPtr2(pointer(module), 2)) and (TPWord(module)^ = CEMAGIC) then begin
|
|
result := pointer(module + dword(pointer(module + CENEWHDR)^));
|
|
if result^.signature <> CPEMAGIC then
|
|
result := nil;
|
|
end;
|
|
except result := nil end;
|
|
end;
|
|
|
|
function GetImageDataDirectory(module: HMODULE; directory: dword) : pointer;
|
|
var nh : PImageNtHeaders32;
|
|
begin
|
|
nh := GetImageNtHeaders(module);
|
|
if nh <> nil then begin
|
|
if nh^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
result := pointer(module + PImageOptionalHeader64(@nh^.OptionalHeader).DataDirectory[directory].VirtualAddress)
|
|
else result := pointer(module + nh^.OptionalHeader .DataDirectory[directory].VirtualAddress);
|
|
end else
|
|
result := nil;
|
|
end;
|
|
|
|
function GetImageImportDirectory(module: HMODULE) : PImageImportDirectory;
|
|
begin
|
|
result := GetImageDataDirectory(module, IMAGE_DIRECTORY_ENTRY_IMPORT);
|
|
end;
|
|
|
|
function GetImageExportDirectory(module: HMODULE) : PImageExportDirectory;
|
|
begin
|
|
result := GetImageDataDirectory(module, IMAGE_DIRECTORY_ENTRY_EXPORT);
|
|
end;
|
|
|
|
function ExportToFunc(module: HMODULE; addr: dword) : pointer;
|
|
var nh : PImageNtHeaders32;
|
|
ed : TImageDataDirectory;
|
|
s1 : AnsiString;
|
|
pc1, pc2 : PAnsiChar;
|
|
dll : HMODULE;
|
|
begin
|
|
nh := GetImageNtHeaders(module);
|
|
if nh <> nil then begin
|
|
if nh^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
ed := PImageOptionalHeader64(@nh^.OptionalHeader).DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT]
|
|
else ed := nh^.OptionalHeader .DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];
|
|
if (addr >= ed.VirtualAddress) and (addr < ed.VirtualAddress + ed.Size) then begin
|
|
s1 := PAnsiChar(module + addr);
|
|
pc1 := PAnsiChar(s1);
|
|
pc2 := pc1;
|
|
repeat
|
|
inc(pc2);
|
|
until pc2^ = '.';
|
|
pc2^ := #0;
|
|
inc(pc2);
|
|
dll := GetModuleHandleA(pc1);
|
|
if (dll <> 0) and (dll <> module) then
|
|
result := GetImageProcAddress(dll, pc2)
|
|
else
|
|
result := nil;
|
|
end else
|
|
result := pointer(module + addr);
|
|
end else
|
|
result := nil;
|
|
end;
|
|
|
|
function VirtualToRaw(nh: PImageNtHeaders32; addr: dword) : dword;
|
|
type TAImageSectionHeader = packed array [0..maxInt shr 6] of TImageSectionHeader;
|
|
var i1 : integer;
|
|
sh : ^TAImageSectionHeader;
|
|
begin
|
|
result := addr;
|
|
if nh^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
sh := pointer(NativeUInt(@nh^.OptionalHeader) + sizeOf(TImageOptionalHeader64))
|
|
else sh := pointer(NativeUInt(@nh^.OptionalHeader) + sizeOf(TImageOptionalHeader32));
|
|
for i1 := 0 to nh^.FileHeader.NumberOfSections - 1 do
|
|
if (addr >= sh[i1].VirtualAddress) and
|
|
((i1 = nh^.FileHeader.NumberOfSections - 1) or (addr < sh[i1 + 1].VirtualAddress)) then begin
|
|
result := addr - sh[i1].VirtualAddress + sh[i1].PointerToRawData;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function GetSizeOfImage(nh: PImageNtHeaders32) : dword;
|
|
begin
|
|
if nh^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
result := PImageOptionalHeader64(@nh.OptionalHeader).SizeOfImage
|
|
else result := nh.OptionalHeader .SizeOfImage;
|
|
end;
|
|
|
|
function NeedModuleFileMap(module: HMODULE) : pointer;
|
|
var arrCh : pointer;
|
|
fh : THandle;
|
|
map : THandle;
|
|
begin
|
|
result := nil;
|
|
if not IsWine then begin
|
|
if GetVersion and $80000000 = 0 then begin
|
|
arrCh := pointer(LocalAlloc(LPTR, 32 * 1024 * 2));
|
|
GetModuleFileNameW(module, arrCh, 32 * 1024);
|
|
fh := CreateFileW(arrCh, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
|
|
end else begin
|
|
arrCh := pointer(LocalAlloc(LPTR, MAX_PATH + 1));
|
|
GetModuleFileNameA(module, arrCh, MAX_PATH);
|
|
fh := CreateFileA(arrCh, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
|
|
end;
|
|
LocalFree(HLOCAL(arrCh));
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
if GetVersion and $80000000 = 0 then
|
|
map := CreateFileMappingW(fh, nil, PAGE_READONLY, 0, 0, nil)
|
|
else map := CreateFileMappingA(fh, nil, PAGE_READONLY, 0, 0, nil);
|
|
if map <> 0 then begin
|
|
result := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
|
|
CloseHandle(map);
|
|
end;
|
|
CloseHandle(fh);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetImageProcAddress(module: HMODULE; const name: AnsiString; doubleCheck: boolean = false) : pointer;
|
|
var ed : PImageExportDirectory;
|
|
nh, nh2 : PImageNtHeaders32;
|
|
i1 : integer;
|
|
c1, c2, c3, c4 : dword;
|
|
w1 : word;
|
|
va, ra : dword;
|
|
buf : pointer;
|
|
p1 : pointer;
|
|
freeBuf : boolean;
|
|
soi : dword;
|
|
begin
|
|
result := nil;
|
|
if module <> 0 then begin
|
|
nh := GetImageNtHeaders(module);
|
|
if nh <> nil then begin
|
|
soi := GetSizeOfImage(nh);
|
|
if nh^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then begin
|
|
va := PImageOptionalHeader64(@nh^.OptionalHeader).DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
|
|
ra := PImageOptionalHeader64(@nh^.OptionalHeader).DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;
|
|
end else begin
|
|
va := nh^.OptionalHeader .DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
|
|
ra := nh^.OptionalHeader .DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;
|
|
end;
|
|
ed := pointer(module + va);
|
|
if ed <> nil then
|
|
for i1 := 0 to ed^.NumberOfNames - 1 do
|
|
if lstrcmpA(pointer(module + TPACardinal(module + ed^.AddressOfNames)^[i1]), pointer(name)) = 0 then begin
|
|
w1 := TPAWord(module + ed^.AddressOfNameOrdinals)^[i1];
|
|
c1 := TPACardinal(module + ed^.AddressOfFunctions)^[w1];
|
|
if doubleCheck or (c1 > soi) then begin
|
|
NativeUInt(p1) := module + c1;
|
|
if (@CheckProcAddress <> nil) and CheckProcAddress(p1) then begin
|
|
result := p1;
|
|
break;
|
|
end;
|
|
if @NeedModuleFileMapEx <> nil then
|
|
buf := NeedModuleFileMapEx(module)
|
|
else
|
|
buf := nil;
|
|
freeBuf := buf = nil;
|
|
if buf = nil then
|
|
buf := NeedModuleFileMap(module);
|
|
if buf <> nil then begin
|
|
try
|
|
nh2 := GetImageNtHeaders(HMODULE(buf));
|
|
if nh2 <> nil then begin
|
|
c2 := ed^.AddressOfNames;
|
|
c3 := ed^.AddressOfFunctions;
|
|
if nh2^.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
c4 := PImageOptionalHeader64(@nh2^.OptionalHeader).DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress
|
|
else
|
|
c4 := nh2^.OptionalHeader .DataDirectory[IMAGE_DIRECTORY_ENTRY_RESOURCE].VirtualAddress;
|
|
NativeUInt(ed) := NativeUInt(buf) + VirtualToRaw(nh, va);
|
|
if (c2 = ed^.AddressOfNames) and (c3 = ed^.AddressOfFunctions) and (c4 = ra) and (soi = GetSizeOfImage(nh2)) then
|
|
c1 := TPACardinal(NativeUInt(buf) + VirtualToRaw(nh, ed^.AddressOfFunctions))^[w1];
|
|
end;
|
|
except end;
|
|
if freeBuf then
|
|
UnmapViewOfFile(buf);
|
|
end;
|
|
end;
|
|
result := ExportToFunc(module, c1);
|
|
break;
|
|
end;
|
|
end;
|
|
if (result = nil) and (module <> 0) then begin
|
|
// nh := GetImageNtHeaders(module);
|
|
// if (nh <> nil) and (nh^.OptionalHeader.Magic = {$ifdef win64} IMAGE_NT_OPTIONAL_HDR64_MAGIC {$else} IMAGE_NT_OPTIONAL_HDR32_MAGIC {$endif}) then
|
|
result := GetProcAddress(module, PAnsiChar(name))
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function Is64bitModule(fileName: PWideChar) : bool; stdcall;
|
|
// find out and return whether the dll file is a 64bit dll
|
|
var fh, map : THandle;
|
|
buf : pointer;
|
|
nh : PImageNtHeaders32;
|
|
begin
|
|
result := false;
|
|
if GetVersion and $80000000 = 0 then
|
|
fh := CreateFileW(fileName, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0)
|
|
else
|
|
fh := CreateFileA(PAnsiChar(AnsiString(UnicodeString(fileName))), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
map := CreateFileMapping(fh, nil, PAGE_READONLY, 0, 0, nil);
|
|
if map <> 0 then begin
|
|
buf := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
|
|
if buf <> nil then begin
|
|
nh := GetImageNtHeaders(HMODULE(buf));
|
|
result := (nh <> nil) and (nh.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC);
|
|
UnmapViewOfFile(buf);
|
|
end;
|
|
CloseHandle(map);
|
|
end;
|
|
CloseHandle(fh);
|
|
end;
|
|
end;
|
|
|
|
function DoesModuleExportOrdinal1(fileName: PWideChar) : boolean; stdcall;
|
|
// does the DLL export an API under the ordinal of 1?
|
|
var fh, map : THandle;
|
|
buf : pointer;
|
|
nh : PImageNtHeaders32;
|
|
va : dword;
|
|
ed : PImageExportDirectory;
|
|
begin
|
|
result := false;
|
|
fh := CreateFileW(fileName, GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
|
|
if fh <> INVALID_HANDLE_VALUE then begin
|
|
map := CreateFileMapping(fh, nil, PAGE_READONLY, 0, 0, nil);
|
|
if map <> 0 then begin
|
|
buf := MapViewOfFile(map, FILE_MAP_READ, 0, 0, 0);
|
|
if buf <> nil then begin
|
|
nh := GetImageNtHeaders(HMODULE(buf));
|
|
if nh <> nil then begin
|
|
if nh.OptionalHeader.Magic = IMAGE_NT_OPTIONAL_HDR64_MAGIC then
|
|
va := PImageOptionalHeader64(@nh.OptionalHeader).DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress
|
|
else
|
|
va := nh.OptionalHeader .DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
|
|
if va <> 0 then begin
|
|
ed := pointer(NativeUInt(buf) + VirtualToRaw(nh, va));
|
|
result := ((ed.Base = 0) and (ed.NumberOfFunctions > 1)) or
|
|
((ed.Base = 1) and (ed.NumberOfFunctions > 0));
|
|
end;
|
|
end;
|
|
UnmapViewOfFile(buf);
|
|
end;
|
|
CloseHandle(map);
|
|
end;
|
|
CloseHandle(fh);
|
|
end;
|
|
end;
|
|
|
|
function GetImageProcAddress(module: HMODULE; index: integer) : pointer; overload;
|
|
var oi : integer;
|
|
// nh : PImageNtHeaders32;
|
|
ed : PImageExportDirectory;
|
|
c1 : dword;
|
|
begin
|
|
result := nil;
|
|
oi := index;
|
|
ed := GetImageExportDirectory(module);
|
|
if ed <> nil then
|
|
with ed^ do begin
|
|
dec(index, Base);
|
|
if (index >= 0) and (index < NumberOfFunctions) then begin
|
|
c1 := TPACardinal(module + AddressOfFunctions)^[index];
|
|
if c1 > 0 then
|
|
result := ExportToFunc(module, c1);
|
|
end;
|
|
end;
|
|
if (result = nil) and (module <> 0) then begin
|
|
// nh := GetImageNtHeaders(module);
|
|
// if (nh <> nil) and (nh^.OptionalHeader.Magic = {$ifdef win64} IMAGE_NT_OPTIONAL_HDR64_MAGIC {$else} IMAGE_NT_OPTIONAL_HDR32_MAGIC {$endif}) then
|
|
result := GetProcAddress(module, PAnsiChar(oi));
|
|
end;
|
|
end;
|
|
|
|
function GetImageProcName(module: HMODULE; proc: pointer; unmangle: boolean) : AnsiString;
|
|
var ed : PImageExportDirectory;
|
|
i1, i2 : integer;
|
|
as1 : AnsiString;
|
|
begin
|
|
if GetVersion and $80000000 <> 0 then begin
|
|
// no idea why we have to do this, but stability suffers in win9x otherwise
|
|
result := AnsiString(GetImageProcNameW(module, proc, unmangle));
|
|
exit;
|
|
end;
|
|
result := '';
|
|
ed := GetImageExportDirectory(module);
|
|
if ed <> nil then
|
|
with ed^ do
|
|
for i1 := 0 to NumberOfFunctions - 1 do
|
|
if module + TPACardinal(module + AddressOfFunctions)^[i1] = NativeUInt(proc) then begin
|
|
for i2 := 0 to NumberOfNames - 1 do
|
|
if TPAWord(module + AddressOfNameOrdinals)^[i2] = i1 then begin
|
|
result := PAnsiChar(module + TPACardinal(module + AddressOfNames)^[i2]);
|
|
break;
|
|
end;
|
|
if result = '' then
|
|
result := '#' + IntToStrExA(Base + dword(i1));
|
|
break;
|
|
end;
|
|
if unmangle and madTools.UnmangleA(result, as1) then
|
|
result := as1 + '.' + result;
|
|
end;
|
|
|
|
function GetImageProcNameW(module: HMODULE; proc: pointer; unmangle: boolean) : UnicodeString;
|
|
var ed : PImageExportDirectory;
|
|
i1, i2 : integer;
|
|
us1 : UnicodeString;
|
|
begin
|
|
result := '';
|
|
ed := GetImageExportDirectory(module);
|
|
if ed <> nil then
|
|
with ed^ do
|
|
for i1 := 0 to NumberOfFunctions - 1 do
|
|
if module + TPACardinal(module + AddressOfFunctions)^[i1] = NativeUInt(proc) then begin
|
|
for i2 := 0 to NumberOfNames - 1 do
|
|
if TPAWord(module + AddressOfNameOrdinals)^[i2] = i1 then begin
|
|
result := UnicodeString(AnsiString(PAnsiChar(module + TPACardinal(module + AddressOfNames)^[i2])));
|
|
break;
|
|
end;
|
|
if result = '' then
|
|
result := '#' + IntToStrExW(Base + dword(i1));
|
|
break;
|
|
end;
|
|
if unmangle and madTools.UnmangleW(result, us1) then
|
|
result := us1 + '.' + result;
|
|
end;
|
|
|
|
function ResToStr(module: HMODULE; resType: PWideChar; const resName: UnicodeString) : AnsiString;
|
|
var res : HRSRC;
|
|
mem : HGLOBAL;
|
|
begin
|
|
result := '';
|
|
if GetVersion and $80000000 = 0 then
|
|
res := FindResourceW(module, PWideChar(resName), resType)
|
|
else
|
|
if PWideChar(byte(resType)) = resType then
|
|
res := FindResourceA(module, PAnsiChar(AnsiString(resName)), pointer(resType))
|
|
else
|
|
res := FindResourceA(module, PAnsiChar(AnsiString(resName)), PAnsiChar(AnsiString(UnicodeString(resType))));
|
|
if res <> 0 then begin
|
|
mem := LoadResource(module, res);
|
|
if mem <> 0 then begin
|
|
SetString(result, PAnsiChar(LockResource(mem)), SizeOfResource(module, res));
|
|
UnlockResource(mem);
|
|
FreeResource(mem);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function UnmangleA(var publicName, unitName: AnsiString) : boolean;
|
|
var i1, i2 : integer;
|
|
b1, b2 : boolean;
|
|
{$ifdef win64}{$ifdef xe3}
|
|
len : integer;
|
|
{$endif}{$endif}
|
|
s2 : AnsiString;
|
|
begin
|
|
result := false;
|
|
unitName := '';
|
|
ReplaceStrA(publicName, '::', '.');
|
|
if (publicName <> '') and (publicName[1] = '@') then begin
|
|
// might be a mangled bpl export, so let's try to unmangle it
|
|
s2 := '';
|
|
if (Length(publicName) > 1) and (publicName[2] = '%') then begin
|
|
for i1 := Length(publicName) - 1 downto 3 do
|
|
if (publicName[i1] = '%') and (publicName[i1 + 1] = '@') then begin
|
|
s2 := '.' + Copy(publicName, i1 + 2, maxInt);
|
|
break;
|
|
end;
|
|
end;
|
|
i2 := 3;
|
|
if (Length(publicName) > 6) and (publicName[2] = '_') and (publicName[3] = '$') then
|
|
for i1 := 5 to Length(publicName) - 1 do
|
|
if publicName[i1] = '$' then begin
|
|
if publicName[i1 + 1] = '@' then
|
|
i2 := i1 + 1;
|
|
break;
|
|
end;
|
|
b1 := false;
|
|
b2 := false;
|
|
for i1 := i2 to Length(publicName) do
|
|
case publicName[i1] of
|
|
'$' : begin
|
|
b1 := (Length(publicName) > i1 + 1) and (publicName[i1 + 2] = 'd');
|
|
Delete(publicName, i1, maxInt);
|
|
publicName := publicName + s2;
|
|
b2 := true;
|
|
break;
|
|
end;
|
|
'@' : begin
|
|
publicName[i1] := '.';
|
|
if unitName = '' then
|
|
unitName := Copy(publicName, 2, i1 - 2)
|
|
end;
|
|
end;
|
|
if unitName <> '' then
|
|
if length(unitName) + 2 < length(publicName) then begin
|
|
Delete(publicName, 1, Length(unitName) + 2);
|
|
b2 := false;
|
|
end else
|
|
unitName := '';
|
|
if b2 then
|
|
Delete(publicName, 1, 1);
|
|
if publicName <> '' then
|
|
if publicName[1] = '%' then Delete(publicName, 1, 1)
|
|
else if publicName[1] = '.' then publicName[1] := '@';
|
|
if (publicName <> '') and (publicName[Length(publicName)] = '.') then
|
|
if b1 then
|
|
publicName := publicName + 'Destroy'
|
|
else publicName := publicName + 'Create';
|
|
TrimStrA(publicName);
|
|
if (publicName <> '') and (publicName[Length(publicName)] = '.') then
|
|
publicName := publicName + '?';
|
|
result := true;
|
|
end {$ifdef win64}{$ifdef xe3} else
|
|
if PosStrIs1A('_ZN', publicName) then begin
|
|
s2 := '';
|
|
i1 := 4;
|
|
while (i1 < Length(publicName)) and (publicName[i1] in ['0'..'9']) do begin
|
|
i2 := i1 + 1;
|
|
while publicName[i2] in ['0'..'9'] do
|
|
inc(i2);
|
|
len := StrToIntExA(false, @publicName[i1], i2 - i1);
|
|
s2 := s2 + '.' + Copy(publicName, i2, len);
|
|
i1 := i2 + len;
|
|
end;
|
|
if (i1 <= Length(publicName)) and (publicName[i1] = 'E') then begin
|
|
Delete(s2, 1, 1);
|
|
if PosStrA('.', s2) > 0 then begin
|
|
unitName := SubStrA(s2, 1, '.');
|
|
publicName := Copy(s2, Length(unitName) + 2, maxInt);
|
|
end else
|
|
publicName := s2;
|
|
result := true;
|
|
end;
|
|
end; {$endif}{$endif}
|
|
end;
|
|
|
|
function UnmangleW(var publicName, unitName: UnicodeString) : boolean;
|
|
var i1, i2 : integer;
|
|
b1, b2 : boolean;
|
|
{$ifdef win64}{$ifdef xe3}
|
|
len : integer;
|
|
{$endif}{$endif}
|
|
s2 : UnicodeString;
|
|
begin
|
|
result := false;
|
|
unitName := '';
|
|
ReplaceStrW(publicName, '::', '.');
|
|
if (publicName <> '') and (publicName[1] = '@') then begin
|
|
// might be a mangled bpl export, so let's try to unmangle it
|
|
s2 := '';
|
|
if (Length(publicName) > 1) and (publicName[2] = '%') then begin
|
|
for i1 := Length(publicName) - 1 downto 3 do
|
|
if (publicName[i1] = '%') and (publicName[i1 + 1] = '@') then begin
|
|
s2 := '.' + Copy(publicName, i1 + 2, maxInt);
|
|
break;
|
|
end;
|
|
end;
|
|
i2 := 3;
|
|
if (Length(publicName) > 6) and (publicName[2] = '_') and (publicName[3] = '$') then
|
|
for i1 := 5 to Length(publicName) - 1 do
|
|
if publicName[i1] = '$' then begin
|
|
if publicName[i1 + 1] = '@' then
|
|
i2 := i1 + 1;
|
|
break;
|
|
end;
|
|
b1 := false;
|
|
b2 := false;
|
|
for i1 := i2 to Length(publicName) do
|
|
case publicName[i1] of
|
|
'$' : begin
|
|
b1 := (Length(publicName) > i1 + 1) and (publicName[i1 + 2] = 'd');
|
|
Delete(publicName, i1, maxInt);
|
|
publicName := publicName + s2;
|
|
b2 := true;
|
|
break;
|
|
end;
|
|
'@' : begin
|
|
publicName[i1] := '.';
|
|
if unitName = '' then
|
|
unitName := Copy(publicName, 2, i1 - 2)
|
|
end;
|
|
end;
|
|
if unitName <> '' then
|
|
if length(unitName) + 2 < length(publicName) then begin
|
|
Delete(publicName, 1, Length(unitName) + 2);
|
|
b2 := false;
|
|
end else
|
|
unitName := '';
|
|
if b2 then
|
|
Delete(publicName, 1, 1);
|
|
if publicName <> '' then
|
|
if publicName[1] = '%' then Delete(publicName, 1, 1)
|
|
else if publicName[1] = '.' then publicName[1] := '@';
|
|
if (publicName <> '') and (publicName[Length(publicName)] = '.') then
|
|
if b1 then
|
|
publicName := publicName + 'Destroy'
|
|
else publicName := publicName + 'Create';
|
|
TrimStrW(publicName);
|
|
if (publicName <> '') and (publicName[Length(publicName)] = '.') then
|
|
publicName := publicName + '?';
|
|
result := true;
|
|
end {$ifdef win64}{$ifdef xe3} else
|
|
if PosStrIs1W('_ZN', publicName) then begin
|
|
s2 := '';
|
|
i1 := 4;
|
|
while (i1 < Length(publicName)) and (WideChar(AnsiChar(publicName[i1])) = publicName[i1]) and (AnsiChar(publicName[i1]) in ['0'..'9']) do begin
|
|
i2 := i1 + 1;
|
|
while (WideChar(AnsiChar(publicName[i2])) = publicName[i2]) and (AnsiChar(publicName[i2]) in ['0'..'9']) do
|
|
inc(i2);
|
|
len := StrToIntExW(false, @publicName[i1], i2 - i1);
|
|
s2 := s2 + '.' + Copy(publicName, i2, len);
|
|
i1 := i2 + len;
|
|
end;
|
|
if (i1 <= Length(publicName)) and (publicName[i1] = 'E') then begin
|
|
Delete(s2, 1, 1);
|
|
if PosStrW('.', s2) > 0 then begin
|
|
unitName := SubStrW(s2, 1, '.');
|
|
publicName := Copy(s2, Length(unitName) + 2, maxInt);
|
|
end else
|
|
publicName := s2;
|
|
result := true;
|
|
end;
|
|
end; {$endif}{$endif}
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
function IsBadReadPtr2(src: pointer; count: dword) : boolean;
|
|
var mbi : TMemoryBasicInformation;
|
|
begin
|
|
result := (VirtualQuery(src, mbi, sizeOf(mbi)) <> sizeOf(mbi)) or (mbi.State <> MEM_COMMIT) or (mbi.Protect and (PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_READONLY or PAGE_READWRITE or PAGE_WRITECOPY) = 0) or (mbi.Protect and PAGE_GUARD <> 0) or
|
|
(NativeUInt(src) + count > NativeUInt(mbi.BaseAddress) + mbi.RegionSize);
|
|
end;
|
|
|
|
function IsBadWritePtr2(dst: pointer; count: dword) : boolean;
|
|
var mbi : TMemoryBasicInformation;
|
|
begin
|
|
result := (VirtualQuery(dst, mbi, sizeOf(mbi)) <> sizeOf(mbi)) or (mbi.State <> MEM_COMMIT) or (mbi.Protect and (PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY or PAGE_READWRITE or PAGE_WRITECOPY) = 0) or (mbi.Protect and PAGE_GUARD <> 0) or
|
|
(NativeUInt(dst) + count > NativeUInt(mbi.BaseAddress) + mbi.RegionSize);
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
function TickDif(tick: dword) : dword;
|
|
var dw : dword;
|
|
begin
|
|
dw := GetTickCount;
|
|
if dw >= tick then
|
|
result := dw - tick
|
|
else result := high(dword) - tick + dw;
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
function GetExceptionObject(er: pointer) : MadException;
|
|
begin
|
|
result := MadException.Create('Unknown exception. If you want to know more, you have to add SysUtils to your project.');
|
|
end;
|
|
|
|
procedure InitTryExceptFinally;
|
|
begin
|
|
if ExceptionClass = nil then begin
|
|
ExceptionClass := MadException;
|
|
ExceptObjProc := @GetExceptionObject;
|
|
end;
|
|
end;
|
|
|
|
// ***************************************************************
|
|
|
|
initialization
|
|
finalization
|
|
FinalMsgHandler;
|
|
end. |