Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

143
contrib/Delphi_MemoryModule/Demo/Project2.dpr Normal file
View File

@@ -0,0 +1,143 @@
program Project2;
{$APPTYPE CONSOLE}
uses
SysUtils, Classes, Windows,
MemoryModule in '..\MemoryModule.pas',
FuncHook in '..\FuncHook.pas',
MemoryModuleHook in '..\MemoryModuleHook.pas';
const
SUsage =
'Test project for loading DLL from memory'+sLineBreak+
'Params:'+sLineBreak+
' [DLL name] (required) - full path to DLL to load'+sLineBreak+
' [Function name] (optional) - function to execute (no parameters, result is DWORD/Handle/Pointer)'+sLineBreak+
'Good testing sample is <%WinDir%\System32\KernelBase.dll> and <GetCurrentThread>';
type
TNativeUIntFunc = function: NativeUInt;
var
ms: TMemoryStream;
lib : TMemoryModule;
func: TNativeUIntFunc;
res: array[0..2] of NativeUInt;
i: Integer;
function GetLibPtrProc(lpLibFileName: PWideChar): Pointer;
begin
// Catch only those paths that start with *, let others go
if lpLibFileName^ = '*' then
Result := ms.Memory;
end;
function CheckLoadLib(lib: Pointer): Boolean;
begin
if lib = nil then
begin
Writeln('Error loading lib '+ParamStr(1)+': '+SysErrorMessage(GetLastError));
Exit(False);
end;
Writeln(ParamStr(1)+' loaded');
Exit(True);
end;
function CheckLoadAndExecFunc(func: TNativeUIntFunc; out res: NativeUInt): Boolean;
begin
if @func = nil then
begin
Writeln('Error loading func '+ParamStr(2)+': '+SysErrorMessage(GetLastError));
Exit(False);
end;
res := func;
Writeln(Format('Function call result: %u (%x)', [res, res]));
Exit(True);
end;
begin
try
if ParamCount = 0 then
begin
Writeln(SUsage);
Exit;
end;
Writeln('===== Test #0, usual load =====');
try
lib := Pointer(LoadLibrary(PChar(ParamStr(1))));
if not CheckLoadLib(lib) then Exit;
if ParamStr(2) <> '' then
begin
func := TNativeUIntFunc(GetProcAddress(HMODULE(lib), PAnsiChar(AnsiString(ParamStr(2)))));
if not CheckLoadAndExecFunc(func, res[0]) then Exit;
end;
finally
FreeLibrary(HMODULE(lib));
end;
Writeln('===== Test #1, load from memory =====');
try
ms := TMemoryStream.Create;
ms.LoadFromFile(ParamStr(1));
ms.Position := 0;
lib := MemoryLoadLibary(ms.Memory);
ms.Free;
if not CheckLoadLib(lib) then Exit;
if ParamStr(2) <> '' then
begin
func := TNativeUIntFunc(MemoryGetProcAddress(lib, PAnsiChar(AnsiString(ParamStr(2)))));
if not CheckLoadAndExecFunc(func, res[1]) then Exit;
end;
finally
MemoryFreeLibrary(lib);
end;
Writeln('===== Test #2, load with hooking =====');
if not InstallHook(@GetLibPtrProc) then
begin
Writeln('Error installing hook');
Exit;
end;
try
ms := TMemoryStream.Create;
ms.LoadFromFile(ParamStr(1));
ms.Position := 0;
// Custom lib names example:
// Adding * char to the lib path for callback to distinguish whether it should act
lib := Pointer(LoadLibrary(PChar('*'+ParamStr(1))));
ms.Free;
if not CheckLoadLib(lib) then Exit;
if ParamStr(2) <> '' then
begin
func := TNativeUIntFunc(GetProcAddress(HMODULE(lib), PAnsiChar(AnsiString(ParamStr(2)))));
if not CheckLoadAndExecFunc(func, res[2]) then Exit;
end;
finally
FreeLibrary(HMODULE(lib));
UninstallHook;
end;
if ParamStr(2) <> '' then
begin
Writeln('===== Test #3, comparing results =====');
for i := Low(res) to High(res) do
if res[i] <> res[0] then
begin
Writeln('Failure! Results vary');
Exit;
end;
Writeln('Success! Results identical')
end;
except on E: Exception do
Writeln('Error: '+E.Message);
end;
Readln;
end.

162
contrib/Delphi_MemoryModule/Demo/Project2.dproj Normal file
View File

@@ -0,0 +1,162 @@
 <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{6C9E4C93-535D-4563-AD0C-384ED9405089}</ProjectGuid>
<ProjectVersion>13.4</ProjectVersion>
<FrameworkType>None</FrameworkType>
<MainSource>Project2.dpr</MainSource>
<Base>True</Base>
<Config Condition="'$(Config)'==''">Debug</Config>
<Platform Condition="'$(Platform)'==''">Win64</Platform>
<TargetedPlatforms>3</TargetedPlatforms>
<AppType>Console</AppType>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win64' and '$(Base)'=='true') or '$(Base_Win64)'!=''">
<Base_Win64>true</Base_Win64>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Base)'=='true') or '$(Base_Win32)'!=''">
<Base_Win32>true</Base_Win32>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_1)'!=''">
<Cfg_1>true</Cfg_1>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="('$(Platform)'=='Win32' and '$(Cfg_1)'=='true') or '$(Cfg_1_Win32)'!=''">
<Cfg_1_Win32>true</Cfg_1_Win32>
<CfgParent>Cfg_1</CfgParent>
<Cfg_1>true</Cfg_1>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_2)'!=''">
<Cfg_2>true</Cfg_2>
<CfgParent>Base</CfgParent>
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_Namespace>System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace)</DCC_Namespace>
<DCC_CodePage>65001</DCC_CodePage>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<Icon_MainIcon>$(BDS)\bin\delphi_PROJECTICON.ico</Icon_MainIcon>
<BRCC_CompilerToUse>rc</BRCC_CompilerToUse>
<DCC_DebugInformation>false</DCC_DebugInformation>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
<BRCC_EnableMultiByte>true</BRCC_EnableMultiByte>
<VerInfo_Locale>1049</VerInfo_Locale>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_UsePackage>soaprtl;bindcompfmx;fmx;dsnap;rtl;dbrtl;fmxase;bindcomp;fmxobj;xmlrtl;ibxpress;DbxCommonDriver;fmxdae;dbxcds;bindengine;dbexpress;$(DCC_UsePackage)</DCC_UsePackage>
<Manifest_File>None</Manifest_File>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win64)'!=''">
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace)</DCC_Namespace>
<DCC_UsePackage>ZCore;vcltouch;ZComponent;vclribbon;VclSmp;vcl;OverbyteIcsDXe2Run;TeeDB;vclib;ZDbc;Tee;ZPlain;ZParseSql;vclx;vclimg;VirtualTreesR;vclactnband;TeeUI;adortl;vcldb;$(DCC_UsePackage)</DCC_UsePackage>
</PropertyGroup>
<PropertyGroup Condition="'$(Base_Win32)'!=''">
<Debugger_RunParams>&quot;E:\tmp\New Folder2\Targets\TLS_Example_1.exe&quot;</Debugger_RunParams>
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_Namespace>Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace)</DCC_Namespace>
<DCC_UsePackage>sdlbasepack_rt_101X2;ZCore;vcltouch;ZComponent;vclribbon;VclSmp;vcl;frx16;OverbyteIcsDXe2Run;TeeDB;CodeSiteExpressPkg;WizFavoritesP;vclib;ZDbc;Tee;ZPlain;sdlgeopack_101X2;ZParseSql;vclx;sdlmathpack_rt_101X2;WizMenuActionsP;vclimg;fmi;sdlgeopack_rt_101X2;bdertl;VirtualTreesR;vclactnband;TeeUI;adortl;vcldb;WizTabToolsP;$(DCC_UsePackage)</DCC_UsePackage>
<VerInfo_Keys>CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments=</VerInfo_Keys>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1)'!=''">
<DCC_CodePage>65001</DCC_CodePage>
<DCC_IntegerOverflowCheck>true</DCC_IntegerOverflowCheck>
<DCC_LocalDebugSymbols>true</DCC_LocalDebugSymbols>
<DCC_MapFile>0</DCC_MapFile>
<DCC_SymbolReferenceInfo>2</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>true</DCC_DebugInformation>
<DCC_RangeChecking>true</DCC_RangeChecking>
<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
<DCC_Optimize>false</DCC_Optimize>
<DCC_GenerateStackFrames>true</DCC_GenerateStackFrames>
<DCC_DebugInfoInExe>true</DCC_DebugInfoInExe>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_1_Win32)'!=''">
<DCC_DebugDCUs>true</DCC_DebugDCUs>
<Debugger_RunParams>C:\Windows\SysWOW64\KernelBase.dll GetCurrentThread</Debugger_RunParams>
<VerInfo_Locale>1033</VerInfo_Locale>
<DCC_RemoteDebug>false</DCC_RemoteDebug>
</PropertyGroup>
<PropertyGroup Condition="'$(Cfg_2)'!=''">
<DCC_CodePage>65001</DCC_CodePage>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<DCC_DebugInformation>false</DCC_DebugInformation>
</PropertyGroup>
<ItemGroup>
<DelphiCompile Include="$(MainSource)">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="..\MemoryModule.pas"/>
<DCCReference Include="..\FuncHook.pas"/>
<DCCReference Include="..\MemoryModuleHook.pas"/>
<BuildConfiguration Include="Release">
<Key>Cfg_2</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
<BuildConfiguration Include="Debug">
<Key>Cfg_1</Key>
<CfgParent>Base</CfgParent>
</BuildConfiguration>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Delphi.Personality>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">False</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">1049</VersionInfo>
<VersionInfo Name="CodePage">1251</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"/>
<VersionInfoKeys Name="FileDescription"/>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"/>
<VersionInfoKeys Name="LegalCopyright"/>
<VersionInfoKeys Name="LegalTrademarks"/>
<VersionInfoKeys Name="OriginalFilename"/>
<VersionInfoKeys Name="ProductName"/>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<Excluded_Packages>
<Excluded_Packages Name="$(BDSBIN)\dclmid160.bpl">Embarcadero MyBase DataAccess Components</Excluded_Packages>
<Excluded_Packages Name="$(BDS)\UserDir\Bpl\test.bpl">(untitled)</Excluded_Packages>
</Excluded_Packages>
<Source>
<Source Name="MainSource">Project2.dpr</Source>
</Source>
</Delphi.Personality>
<Platforms>
<Platform value="Win64">True</Platform>
<Platform value="Win32">True</Platform>
</Platforms>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<Import Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')" Project="$(BDS)\Bin\CodeGear.Delphi.Targets"/>
<Import Condition="Exists('$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj')" Project="$(APPDATA)\Embarcadero\$(BDSAPPDATABASEDIR)\$(PRODUCTVERSION)\UserTools.proj"/>
</Project>

168
contrib/Delphi_MemoryModule/FuncHook.pas Normal file
View File

@@ -0,0 +1,168 @@
(*==============================================================================
====== Function hooking ======
Functions exported from DLL contain single instruction "JMP [fn_addr]" that
points to actual code. So there could be 2 ways of hooking:
1) Patch the JMP not touching the code
+ Original proc could be called via HookInfo.OrigProc
- (or feature) Only the one imported function is hooked. If there's another
export definition or dynamic load, the hook won't change them.
2) Patch the very code as usual
+ All function imports are impacted
- No way to use original proc
2nd way is called "strict address mode" here and is controlled by HookProcedure()'s
StrictMode parameter.
Compatibility: RAD Studio 2009+ (uses advanced records and Exit(param)), x32/x64.
==============================================================================*)
unit FuncHook;
interface
uses
Windows;
type
TInjectInstr = packed record
Opcode: UInt8;
Offset: Int32;
end;
PInjectInstr = ^TInjectInstr;
THookInfo = record
private
OrigCode: TInjectInstr; // Original instruction
HookCode: TInjectInstr; // Hook instruction (saved only for check on uninstall)
ProcAddr: Pointer; // Address of a routine to hook
TrampAddr: Pointer; // Address of a trampoline (original routine; DLL exports only)
HookAddr: Pointer; // Address of a hook routine
StrictMode: Boolean; // Hook was installed in strict address mode
public
procedure Init(ProcAddr, HookAddr: Pointer);
property OrigProc: Pointer read TrampAddr;
end;
function HookProcedure(StrictMode: Boolean; var HookInfo: THookInfo): Boolean;
function UnhookProcedure(var HookInfo: THookInfo): Boolean;
implementation
const
INDIRECT_JMP = $25FF;
RELATIVE_JMP = $E9;
EmptyInstr: TInjectInstr = (Opcode: 0; Offset: Int32($DEADBEEF));
function IsEqual(const Instr1, Instr2: TInjectInstr): Boolean;
begin
Result := (Instr1.Opcode = Instr2.Opcode) and (Instr1.Offset = Instr2.Offset);
end;
{ THookInfo }
procedure THookInfo.Init(ProcAddr, HookAddr: Pointer);
begin
ZeroMemory(@Self, SizeOf(Self));
OrigCode := EmptyInstr;
Self.ProcAddr := ProcAddr;
Self.HookAddr := HookAddr;
end;
// Utility function to (un)install hook by patching function code.
// Install: (un)install the hook
// HookInfo: all required data
// Returns: True = success, False = fail
function PatchCode(Install: Boolean; var HookInfo: THookInfo): Boolean;
// Get the real address of a function (for functions exported from DLL)
function GetStrictAddr: Pointer;
type
TAbsIndirectJmp = packed record
OpCode: UInt16; // $FF25 (x32: Jmp, FF /4; x64: Jmp, Rel /4)
Addr : Int32;
end;
PAbsIndirectJmp = ^TAbsIndirectJmp;
var
jmp: PAbsIndirectJmp;
begin
Result := nil;
jmp := PAbsIndirectJmp(HookInfo.ProcAddr);
if jmp.OpCode = INDIRECT_JMP then
{$IFDEF CPUX86}
Result := PPointer(jmp.Addr)^;
{$ENDIF}
{$IFDEF CPUX64}
Result := PPointer(PByte(HookInfo.ProcAddr) + jmp.Addr + SizeOf(TAbsIndirectJmp))^;
{$ENDIF}
end;
var
OldProtect: DWORD;
DestAddr: PInjectInstr;
begin
// Check strict address mode
if HookInfo.StrictMode
then DestAddr := GetStrictAddr
else DestAddr := HookInfo.ProcAddr;
Result := VirtualProtect(DestAddr, SizeOf(TInjectInstr), PAGE_EXECUTE_READWRITE, OldProtect);
if not Result then Exit;
if Install then
begin
// For functions exported from DLL, the only instruction they contain is
// "JMP [fn_addr]" so we can save the address as a trampoline
if not HookInfo.StrictMode
then HookInfo.TrampAddr := GetStrictAddr
else HookInfo.TrampAddr := nil;
HookInfo.OrigCode := DestAddr^;
DestAddr^ := HookInfo.HookCode;
end
else
begin
// Check that patch wasn't overwritten
if IsEqual(HookInfo.HookCode, DestAddr^) then
begin
DestAddr^ := HookInfo.OrigCode;
// Clear OrigCode field thus indicating that hook is not installed
HookInfo.OrigCode := EmptyInstr;
HookInfo.StrictMode := False;
end
else
Result := False;
end;
FlushInstructionCache(GetCurrentProcess, DestAddr, SizeOf(TInjectInstr));
VirtualProtect(DestAddr, SizeOf(TInjectInstr), OldProtect, OldProtect);
end;
// Install the hook
// StrictMode: "strict address mode" flag
// HookInfo: all required data
// Returns: True = success, False = fail
function HookProcedure(StrictMode: Boolean; var HookInfo: THookInfo): Boolean;
begin
// Required data is missing?
if (HookInfo.HookAddr = nil) or (HookInfo.ProcAddr = nil) or
// Hook is installed already?
not IsEqual(HookInfo.OrigCode, EmptyInstr) then
Exit(False);
HookInfo.HookCode.Opcode := RELATIVE_JMP;
HookInfo.HookCode.Offset := PByte(HookInfo.HookAddr) - PByte(HookInfo.ProcAddr) - SizeOf(TInjectInstr);
HookInfo.StrictMode := StrictMode;
Result := PatchCode(True, HookInfo);
end;
// Uninstall the hook
// HookInfo: all required data
// Returns: True = success, False = fail
function UnhookProcedure(var HookInfo: THookInfo): Boolean;
begin
// Required data is missing?
if (HookInfo.HookAddr = nil) or (HookInfo.ProcAddr = nil) or
// Hook is not installed yet?
IsEqual(HookInfo.OrigCode, EmptyInstr) then
Exit(False);
Result := PatchCode(False, HookInfo);
end;
end.

831
contrib/Delphi_MemoryModule/MemoryModule.pas Normal file
View File

@@ -0,0 +1,831 @@
// To compile under FPC, Delphi mode must be used
// Also define CPUX64 for simplicity
{$IFDEF FPC}
{$mode delphi}
{$IFDEF CPU64}
{$DEFINE CPUX64}
{$ENDIF}
{$ENDIF}
unit MemoryModule;
{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* Memory DLL loading code
* ------------------------
*
* Original C Code
* Memory DLL loading code
* Version 0.0.4
*
* Copyright (c) 2004-2015 by Joachim Bauch / mail@joachim-bauch.de
* http://www.joachim-bauch.de
*
* The contents of this file are subject to the Mozilla Public License Version
* 2.0 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is MemoryModule.c
*
* The Initial Developer of the Original Code is Joachim Bauch.
*
* Portions created by Joachim Bauch are Copyright (C) 2004-2015
* Joachim Bauch. All Rights Reserved.
*
* ================== MemoryModule "Conversion to Delphi" ==================
*
* Copyright (c) 2015 by Fr0sT / https://github.com/Fr0sT-Brutal
*
* Initially based on the code by:
* Copyright (c) 2005 - 2006 by Martin Offenwanger / coder@dsplayer.de / http://www.dsplayer.de
* Carlo Pasolini / cdpasop@hotmail.it / http://pasotech.altervista.org
*
* NOTE
* This code is Delphi translation of original C code taken from https://github.com/fancycode/MemoryModule
* (commit dc173ca from Mar 1, 2015).
* Resource loading and exe loading, custom functions, user data not implemented yet.
* Tested under RAD Studio XE2 and XE6 32/64-bit, Lazarus 32-bit
* }
interface
uses
Windows;
type
TMemoryModule = Pointer;
{ ++++++++++++++++++++++++++++++++++++++++++++++++++
*** Memory DLL loading functions Declaration ***
-------------------------------------------------- }
// return value is nil if function fails
function MemoryLoadLibary(Data: Pointer): TMemoryModule; stdcall;
// return value is nil if function fails
function MemoryGetProcAddress(Module: TMemoryModule; const Name: PAnsiChar): Pointer; stdcall;
// free module
procedure MemoryFreeLibrary(Module: TMemoryModule); stdcall;
implementation
{ ++++++++++++++++++++++++++++++++++++++++
*** Missing Windows API Definitions ***
---------------------------------------- }
{$IF NOT DECLARED(IMAGE_BASE_RELOCATION)}
type
{$ALIGN 4}
IMAGE_BASE_RELOCATION = record
VirtualAddress: DWORD;
SizeOfBlock: DWORD;
end;
{$ALIGN ON}
PIMAGE_BASE_RELOCATION = ^IMAGE_BASE_RELOCATION;
{$IFEND}
// Types that are declared in Pascal-style (ex.: PImageOptionalHeader); redeclaring them in C-style
{$IF NOT DECLARED(PIMAGE_DATA_DIRECTORY)}
type PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY;
{$IFEND}
{$IF NOT DECLARED(PIMAGE_SECTION_HEADER)}
type PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER;
{$IFEND}
{$IF NOT DECLARED(PIMAGE_EXPORT_DIRECTORY)}
type PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY;
{$IFEND}
{$IF NOT DECLARED(PIMAGE_DOS_HEADER)}
type PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER;
{$IFEND}
{$IF NOT DECLARED(PIMAGE_NT_HEADERS)}
type PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;
{$IFEND}
{$IF NOT DECLARED(PUINT_PTR)}
type PUINT_PTR = ^UINT_PTR;
{$IFEND}
// Missing constants
const
IMAGE_REL_BASED_ABSOLUTE = 0;
IMAGE_REL_BASED_HIGHLOW = 3;
IMAGE_REL_BASED_DIR64 = 10;
// Things that are incorrectly defined at least up to XE6 (miss x64 mapping)
{$IFDEF CPUX64}
type
PIMAGE_TLS_DIRECTORY = PIMAGE_TLS_DIRECTORY64;
const
IMAGE_ORDINAL_FLAG = IMAGE_ORDINAL_FLAG64;
{$ENDIF}
{ +++++++++++++++++++++++++++++++++++++++++++++++
*** Internal MemoryModule Const Definition ***
----------------------------------------------- }
const
IMAGE_SIZEOF_BASE_RELOCATION = SizeOf(IMAGE_BASE_RELOCATION);
{$IFDEF CPUX64}
HOST_MACHINE = IMAGE_FILE_MACHINE_AMD64;
{$ELSE}
HOST_MACHINE = IMAGE_FILE_MACHINE_I386;
{$ENDIF}
type
{ +++++++++++++++++++++++++++++++++++++++++++++++
*** Internal MemoryModule Type Definition ***
----------------------------------------------- }
TMemoryModuleRec = record
Headers: PIMAGE_NT_HEADERS;
CodeBase: Pointer;
Modules: array of HMODULE;
NumModules: Integer;
Initialized: Boolean;
IsRelocated: Boolean;
PageSize: DWORD;
end;
PMemoryModule = ^TMemoryModuleRec;
TDllEntryProc = function(hinstDLL: HINST; fdwReason: DWORD; lpReserved: Pointer): BOOL; stdcall;
TSectionFinalizeData = record
Address: Pointer;
AlignedAddress: Pointer;
Size: SIZE_T;
Characteristics: DWORD;
Last: Boolean;
end;
// Explicitly export these functions to allow hooking of their origins
function GetProcAddress_Internal(hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall; external kernel32 name 'GetProcAddress';
function LoadLibraryA_Internal(lpLibFileName: LPCSTR): HMODULE; stdcall; external kernel32 name 'LoadLibraryA';
function FreeLibrary_Internal(hLibModule: HMODULE): BOOL; stdcall; external kernel32 name 'FreeLibrary';
// Just an imitation to allow using try-except block. DO NOT try to handle this
// like "on E do ..." !
procedure Abort;
begin
raise TObject.Create;
end;
// Copy from SysUtils to get rid of this unit
function StrComp(const Str1, Str2: PAnsiChar): Integer;
var
P1, P2: PAnsiChar;
begin
P1 := Str1;
P2 := Str2;
while True do
begin
if (P1^ <> P2^) or (P1^ = #0) then
Exit(Ord(P1^) - Ord(P2^));
Inc(P1);
Inc(P2);
end;
end;
{ +++++++++++++++++++++++++++++++++++++++++++++++++++++
*** Missing WinAPI macros ***
----------------------------------------------------- }
{$IF NOT DECLARED(IMAGE_ORDINAL)}
// #define IMAGE_ORDINAL64(Ordinal) (Ordinal & 0xffff)
// #define IMAGE_ORDINAL32(Ordinal) (Ordinal & 0xffff)
function IMAGE_ORDINAL(Ordinal: NativeUInt): Word; inline;
begin
Result := Ordinal and $FFFF;
end;
{$IFEND}
{$IF NOT DECLARED(IMAGE_SNAP_BY_ORDINAL)}
// IMAGE_SNAP_BY_ORDINAL64(Ordinal) ((Ordinal & IMAGE_ORDINAL_FLAG64) != 0)
// IMAGE_SNAP_BY_ORDINAL32(Ordinal) ((Ordinal & IMAGE_ORDINAL_FLAG32) != 0)
function IMAGE_SNAP_BY_ORDINAL(Ordinal: NativeUInt): Boolean; inline;
begin
Result := ((Ordinal and IMAGE_ORDINAL_FLAG) <> 0);
end;
{$IFEND}
{ +++++++++++++++++++++++++++++++++++++++++++++++++++++
*** Helper functions ***
----------------------------------------------------- }
function GET_HEADER_DICTIONARY(Module: PMemoryModule; Idx: Integer): PIMAGE_DATA_DIRECTORY;
begin
Result := PIMAGE_DATA_DIRECTORY(@(Module.Headers.OptionalHeader.DataDirectory[Idx]));
end;
function ALIGN_DOWN(Address: Pointer; Alignment: DWORD): Pointer;
begin
Result := Pointer(UIntPtr(Address) and not (Alignment - 1));
end;
function CopySections(data: Pointer; old_headers: PIMAGE_NT_HEADERS; module: PMemoryModule): Boolean;
var
i, Size: Integer;
CodeBase: Pointer;
dest: Pointer;
Section: PIMAGE_SECTION_HEADER;
begin
CodeBase := Module.CodeBase;
Section := PIMAGE_SECTION_HEADER(IMAGE_FIRST_SECTION(Module.Headers{$IFNDEF FPC}^{$ENDIF}));
for i := 0 to Module.Headers.FileHeader.NumberOfSections - 1 do
begin
// Section doesn't contain data in the dll itself, but may define
// uninitialized Data
if Section.SizeOfRawData = 0 then
begin
Size := Old_headers.OptionalHeader.SectionAlignment;
if Size > 0 then
begin
dest := VirtualAlloc(PByte(CodeBase) + Section.VirtualAddress,
Size,
MEM_COMMIT,
PAGE_READWRITE);
if dest = nil then
Exit(False);
// Always use position from file to support alignments smaller
// than page Size.
dest := PByte(CodeBase) + Section.VirtualAddress;
Section.Misc.PhysicalAddress := DWORD(dest);
ZeroMemory(dest, Size);
end;
// Section is empty
Inc(Section);
Continue;
end; // if
// commit memory block and copy Data from dll
dest := VirtualAlloc(PByte(CodeBase) + Section.VirtualAddress,
Section.SizeOfRawData,
MEM_COMMIT,
PAGE_READWRITE);
if dest = nil then
Exit(False);
// Always use position from file to support alignments smaller
// than page Size.
dest := PByte(CodeBase) + Section.VirtualAddress;
CopyMemory(dest, PByte(Data) + Section.PointerToRawData, Section.SizeOfRawData);
Section.Misc.PhysicalAddress := DWORD(dest);
Inc(Section);
end; // for
Result := True;
end;
// Protection flags for memory pages (Executable, Readable, Writeable)
const
ProtectionFlags: array[Boolean, Boolean, Boolean] of DWORD =
(
(
// not executable
(PAGE_NOACCESS, PAGE_WRITECOPY),
(PAGE_READONLY, PAGE_READWRITE)
),
(
// executable
(PAGE_EXECUTE, PAGE_EXECUTE_WRITECOPY),
(PAGE_EXECUTE_READ, PAGE_EXECUTE_READWRITE)
)
);
function GetRealSectionSize(Module: PMemoryModule; Section: PIMAGE_SECTION_HEADER): DWORD;
begin
Result := Section.SizeOfRawData;
if Result = 0 then
if (Section.Characteristics and IMAGE_SCN_CNT_INITIALIZED_DATA) <> 0 then
Result := Module.Headers.OptionalHeader.SizeOfInitializedData
else if (Section.Characteristics and IMAGE_SCN_CNT_UNINITIALIZED_DATA) <> 0 then
Result := Module.Headers.OptionalHeader.SizeOfUninitializedData;
end;
function FinalizeSection(Module: PMemoryModule; const SectionData: TSectionFinalizeData): Boolean;
var
protect, oldProtect: DWORD;
executable, readable, writeable: Boolean;
begin
if SectionData.Size = 0 then
Exit(True);
if (SectionData.Characteristics and IMAGE_SCN_MEM_DISCARDABLE) <> 0 then
begin
// Section is not needed any more and can safely be freed
if (SectionData.Address = SectionData.AlignedAddress) and
( SectionData.Last or
(Module.Headers.OptionalHeader.SectionAlignment = Module.PageSize) or
(SectionData.Size mod Module.PageSize = 0)
) then
// Only allowed to decommit whole pages
VirtualFree(SectionData.Address, SectionData.Size, MEM_DECOMMIT);
Exit(True);
end;
// determine protection flags based on Characteristics
executable := (SectionData.Characteristics and IMAGE_SCN_MEM_EXECUTE) <> 0;
readable := (SectionData.Characteristics and IMAGE_SCN_MEM_READ) <> 0;
writeable := (SectionData.Characteristics and IMAGE_SCN_MEM_WRITE) <> 0;
protect := ProtectionFlags[executable][readable][writeable];
if (SectionData.Characteristics and IMAGE_SCN_MEM_NOT_CACHED) <> 0 then
protect := protect or PAGE_NOCACHE;
// change memory access flags
Result := VirtualProtect(SectionData.Address, SectionData.Size, protect, oldProtect);
end;
function FinalizeSections(Module: PMemoryModule): Boolean;
var
i: Integer;
Section: PIMAGE_SECTION_HEADER;
imageOffset: UIntPtr;
SectionData: TSectionFinalizeData;
sectionAddress, AlignedAddress: Pointer;
sectionSize: DWORD;
begin
Section := PIMAGE_SECTION_HEADER(IMAGE_FIRST_SECTION(Module.Headers{$IFNDEF FPC}^{$ENDIF}));
{$IFDEF CPUX64}
imageOffset := (NativeUInt(Module.CodeBase) and $ffffffff00000000);
{$ELSE}
imageOffset := 0;
{$ENDIF}
SectionData.Address := Pointer(UIntPtr(Section.Misc.PhysicalAddress) or imageOffset);
SectionData.AlignedAddress := ALIGN_DOWN(SectionData.Address, Module.PageSize);
SectionData.Size := GetRealSectionSize(Module, Section);
SectionData.Characteristics := Section.Characteristics;
SectionData.Last := False;
Inc(Section);
// loop through all sections and change access flags
for i := 1 to Module.Headers.FileHeader.NumberOfSections - 1 do
begin
sectionAddress := Pointer(UIntPtr(Section.Misc.PhysicalAddress) or imageOffset);
AlignedAddress := ALIGN_DOWN(SectionData.Address, Module.PageSize);
sectionSize := GetRealSectionSize(Module, Section);
// Combine access flags of all sections that share a page
// TODO(fancycode): We currently share flags of a trailing large Section
// with the page of a first small Section. This should be optimized.
if (SectionData.AlignedAddress = AlignedAddress) or
(PByte(SectionData.Address) + SectionData.Size > PByte(AlignedAddress)) then
begin
// Section shares page with previous
if (Section.Characteristics and IMAGE_SCN_MEM_DISCARDABLE = 0) or
(SectionData.Characteristics and IMAGE_SCN_MEM_DISCARDABLE = 0) then
SectionData.Characteristics := (SectionData.Characteristics or Section.Characteristics) and not IMAGE_SCN_MEM_DISCARDABLE
else
SectionData.Characteristics := SectionData.Characteristics or Section.Characteristics;
SectionData.Size := PByte(sectionAddress) + sectionSize - PByte(SectionData.Address);
Inc(Section);
Continue;
end;
if not FinalizeSection(Module, SectionData) then
Exit(False);
SectionData.Address := sectionAddress;
SectionData.AlignedAddress := AlignedAddress;
SectionData.Size := sectionSize;
SectionData.Characteristics := Section.Characteristics;
Inc(Section);
end; // for
SectionData.Last := True;
if not FinalizeSection(Module, SectionData) then
Exit(False);
Result := True;
end;
function ExecuteTLS(Module: PMemoryModule): Boolean;
var
CodeBase: Pointer;
directory: PIMAGE_DATA_DIRECTORY;
tls: PIMAGE_TLS_DIRECTORY;
callback: PPointer; // =^PIMAGE_TLS_CALLBACK;
// TLS callback pointers are VA's (ImageBase included) so if the module resides at
// the other ImageBage they become invalid. This routine relocates them to the
// actual ImageBase.
// The case seem to happen with DLLs only and they rarely use TLS callbacks.
// Moreover, they probably don't work at all when using DLL dynamically which is
// the case in our code.
function FixPtr(OldPtr: Pointer): Pointer;
begin
Result := Pointer(NativeInt(OldPtr) - Module.Headers.OptionalHeader.ImageBase + NativeInt(CodeBase));
end;
begin
Result := True;
CodeBase := Module.CodeBase;
directory := GET_HEADER_DICTIONARY(Module, IMAGE_DIRECTORY_ENTRY_TLS);
if directory.VirtualAddress = 0 then
Exit;
tls := PIMAGE_TLS_DIRECTORY(PByte(CodeBase) + directory.VirtualAddress);
// Delphi syntax is quite awkward when dealing with proc pointers so we have to
// use casts to untyped pointers
callback := Pointer(tls.AddressOfCallBacks);
if callback <> nil then
begin
callback := FixPtr(callback);
while callback^ <> nil do
begin
PIMAGE_TLS_CALLBACK(FixPtr(callback^))(CodeBase, DLL_PROCESS_ATTACH, nil);
Inc(callback);
end;
end;
end;
function PerformBaseRelocation(Module: PMemoryModule; Delta: NativeInt): Boolean;
var
i: Cardinal;
CodeBase: Pointer;
directory: PIMAGE_DATA_DIRECTORY;
relocation: PIMAGE_BASE_RELOCATION;
dest: Pointer;
relInfo: ^UInt16;
patchAddrHL: PDWORD;
{$IFDEF CPUX64}
patchAddr64: PULONGLONG;
{$ENDIF}
relType, offset: Integer;
begin
CodeBase := Module.CodeBase;
directory := GET_HEADER_DICTIONARY(Module, IMAGE_DIRECTORY_ENTRY_BASERELOC);
if directory.Size = 0 then
Exit(Delta = 0);
relocation := PIMAGE_BASE_RELOCATION(PByte(CodeBase) + directory.VirtualAddress);
while relocation.VirtualAddress > 0 do
begin
dest := Pointer(PByte(CodeBase) + relocation.VirtualAddress);
relInfo := Pointer(PByte(relocation) + IMAGE_SIZEOF_BASE_RELOCATION);
for i := 0 to Trunc(((relocation.SizeOfBlock - IMAGE_SIZEOF_BASE_RELOCATION) / 2)) - 1 do
begin
// the upper 4 bits define the type of relocation
relType := relInfo^ shr 12;
// the lower 12 bits define the offset
offset := relInfo^ and $FFF;
case relType of
IMAGE_REL_BASED_ABSOLUTE:
// skip relocation
;
IMAGE_REL_BASED_HIGHLOW:
begin
// change complete 32 bit address
patchAddrHL := Pointer(PByte(dest) + offset);
Inc(patchAddrHL^, Delta);
end;
{$IFDEF CPUX64}
IMAGE_REL_BASED_DIR64:
begin
patchAddr64 := Pointer(PByte(dest) + offset);
Inc(patchAddr64^, Delta);
end;
{$ENDIF}
end;
Inc(relInfo);
end; // for
// advance to next relocation block
relocation := PIMAGE_BASE_RELOCATION(PByte(relocation) + relocation.SizeOfBlock);
end; // while
Result := True;
end;
function BuildImportTable(Module: PMemoryModule): Boolean; stdcall;
var
CodeBase: Pointer;
directory: PIMAGE_DATA_DIRECTORY;
importDesc: PIMAGE_IMPORT_DESCRIPTOR;
thunkRef: PUINT_PTR;
funcRef: ^FARPROC;
handle: HMODULE;
thunkData: PIMAGE_IMPORT_BY_NAME;
begin
CodeBase := Module.CodeBase;
Result := True;
directory := GET_HEADER_DICTIONARY(Module, IMAGE_DIRECTORY_ENTRY_IMPORT);
if directory.Size = 0 then
Exit(True);
importDesc := PIMAGE_IMPORT_DESCRIPTOR(PByte(CodeBase) + directory.VirtualAddress);
while (not IsBadReadPtr(importDesc, SizeOf(IMAGE_IMPORT_DESCRIPTOR))) and (importDesc.Name <> 0) do
begin
handle := LoadLibraryA_Internal(PAnsiChar(PByte(CodeBase) + importDesc.Name));
if handle = 0 then
begin
SetLastError(ERROR_MOD_NOT_FOUND);
Result := False;
Break;
end;
try
SetLength(Module.Modules, Module.NumModules + 1);
except
FreeLibrary_Internal(handle);
SetLastError(ERROR_OUTOFMEMORY);
Result := False;
Break;
end;
Module.Modules[Module.NumModules] := handle;
Inc(Module.NumModules);
if importDesc.OriginalFirstThunk <> 0 then
begin
thunkRef := Pointer(PByte(CodeBase) + importDesc.OriginalFirstThunk);
funcRef := Pointer(PByte(CodeBase) + importDesc.FirstThunk);
end
else
begin
// no hint table
thunkRef := Pointer(PByte(CodeBase) + importDesc.FirstThunk);
funcRef := Pointer(PByte(CodeBase) + importDesc.FirstThunk);
end;
while thunkRef^ <> 0 do
begin
if IMAGE_SNAP_BY_ORDINAL(thunkRef^) then
funcRef^ := GetProcAddress_Internal(handle, PAnsiChar(IMAGE_ORDINAL(thunkRef^)))
else
begin
thunkData := PIMAGE_IMPORT_BY_NAME(PByte(CodeBase) + thunkRef^);
funcRef^ := GetProcAddress_Internal(handle, PAnsiChar(@(thunkData.Name)));
end;
if funcRef^ = nil then
begin
Result := False;
Break;
end;
Inc(funcRef);
Inc(thunkRef);
end; // while
if not Result then
begin
FreeLibrary_Internal(handle);
SetLastError(ERROR_PROC_NOT_FOUND);
Break;
end;
Inc(importDesc);
end; // while
end;
{ +++++++++++++++++++++++++++++++++++++++++++++++++++++
*** Memory DLL loading functions Implementation ***
----------------------------------------------------- }
function MemoryLoadLibary(Data: Pointer): TMemoryModule; stdcall;
var
dos_header: PIMAGE_DOS_HEADER;
old_header: PIMAGE_NT_HEADERS;
code, Headers: Pointer;
locationdelta: NativeInt;
sysInfo: SYSTEM_INFO;
DllEntry: TDllEntryProc;
successfull: Boolean;
Module: PMemoryModule;
begin
Result := nil; Module := nil;
try
dos_header := PIMAGE_DOS_HEADER(Data);
if (dos_header.e_magic <> IMAGE_DOS_SIGNATURE) then
begin
SetLastError(ERROR_BAD_EXE_FORMAT);
Exit;
end;
// old_header = (PIMAGE_NT_HEADERS)&((const unsigned char * )(Data))[dos_header->e_lfanew];
old_header := PIMAGE_NT_HEADERS(PByte(Data) + dos_header._lfanew);
if old_header.Signature <> IMAGE_NT_SIGNATURE then
begin
SetLastError(ERROR_BAD_EXE_FORMAT);
Exit;
end;
{$IFDEF CPUX64}
if old_header.FileHeader.Machine <> IMAGE_FILE_MACHINE_AMD64 then
{$ELSE}
if old_header.FileHeader.Machine <> IMAGE_FILE_MACHINE_I386 then
{$ENDIF}
begin
SetLastError(ERROR_BAD_EXE_FORMAT);
Exit;
end;
if (old_header.OptionalHeader.SectionAlignment and 1) <> 0 then
begin
// Only support section alignments that are a multiple of 2
SetLastError(ERROR_BAD_EXE_FORMAT);
Exit;
end;
// reserve memory for image of library
// XXX: is it correct to commit the complete memory region at once?
// calling DllEntry raises an exception if we don't...
code := VirtualAlloc(Pointer(old_header.OptionalHeader.ImageBase),
old_header.OptionalHeader.SizeOfImage,
MEM_RESERVE or MEM_COMMIT,
PAGE_READWRITE);
if code = nil then
begin
// try to allocate memory at arbitrary position
code := VirtualAlloc(nil,
old_header.OptionalHeader.SizeOfImage,
MEM_RESERVE or MEM_COMMIT,
PAGE_READWRITE);
if code = nil then
begin
SetLastError(ERROR_OUTOFMEMORY);
Exit;
end;
end;
Module := PMemoryModule(HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, SizeOf(TMemoryModuleRec)));
if Module = nil then
begin
VirtualFree(code, 0, MEM_RELEASE);
SetLastError(ERROR_OUTOFMEMORY);
Exit;
end;
// memory is zeroed by HeapAlloc
Module.CodeBase := code;
GetNativeSystemInfo({$IFDEF FPC}@{$ENDIF}sysInfo);
Module.PageSize := sysInfo.dwPageSize;
// commit memory for Headers
Headers := VirtualAlloc(code,
old_header.OptionalHeader.SizeOfHeaders,
MEM_COMMIT,
PAGE_READWRITE);
// copy PE header to code
CopyMemory(Headers, dos_header, old_header.OptionalHeader.SizeOfHeaders);
// result->Headers = (PIMAGE_NT_HEADERS)&((const unsigned char *)(Headers))[dos_header->e_lfanew];
Module.Headers := PIMAGE_NT_HEADERS(PByte(Headers) + dos_header._lfanew);
// copy sections from DLL file block to new memory location
if not CopySections(Data, old_header, Module) then
Abort;
// adjust base address of imported data
locationdelta := NativeInt(code) - old_header.OptionalHeader.ImageBase;
if locationdelta <> 0 then
Module.IsRelocated := PerformBaseRelocation(Module, locationdelta)
else
Module.IsRelocated := True;
// load required dlls and adjust function table of imports
if not BuildImportTable(Module) then
Abort;
// mark memory pages depending on Section Headers and release
// sections that are marked as "discardable"
if not FinalizeSections(Module) then
Abort;
// TLS callbacks are executed BEFORE the main loading
if not ExecuteTLS(Module) then
Abort;
// get entry point of loaded library
if Module.Headers.OptionalHeader.AddressOfEntryPoint <> 0 then
begin
@DllEntry := Pointer(PByte(code) + Module.Headers.OptionalHeader.AddressOfEntryPoint);
// notify library about attaching to process
successfull := DllEntry(HINST(code), DLL_PROCESS_ATTACH, nil);
if not successfull then
begin
SetLastError(ERROR_DLL_INIT_FAILED);
Abort;
end;
Module.Initialized := True;
end;
Result := Module;
except
// cleanup
MemoryFreeLibrary(Module);
Exit;
end;
end;
function MemoryGetProcAddress(Module: TMemoryModule; const Name: PAnsiChar): Pointer; stdcall;
var
CodeBase: Pointer;
Idx: Integer;
i: DWORD;
nameRef: PDWORD;
ordinal: PWord;
exportDir: PIMAGE_EXPORT_DIRECTORY;
directory: PIMAGE_DATA_DIRECTORY;
temp: PDWORD;
mmodule: PMemoryModule;
begin
Result := nil;
mmodule := PMemoryModule(Module);
CodeBase := mmodule.CodeBase;
directory := GET_HEADER_DICTIONARY(mmodule, IMAGE_DIRECTORY_ENTRY_EXPORT);
// no export table found
if directory.Size = 0 then
begin
SetLastError(ERROR_PROC_NOT_FOUND);
Exit;
end;
exportDir := PIMAGE_EXPORT_DIRECTORY(PByte(CodeBase) + directory.VirtualAddress);
// DLL doesn't export anything
if (exportDir.NumberOfNames = 0) or (exportDir.NumberOfFunctions = 0) then
begin
SetLastError(ERROR_PROC_NOT_FOUND);
Exit;
end;
// search function name in list of exported names
nameRef := Pointer(PByte(CodeBase) + exportDir.AddressOfNames);
ordinal := Pointer(PByte(CodeBase) + exportDir.AddressOfNameOrdinals);
Idx := -1;
for i := 0 to exportDir.NumberOfNames - 1 do
begin
if StrComp(Name, PAnsiChar(PByte(CodeBase) + nameRef^)) = 0 then
begin
Idx := ordinal^;
Break;
end;
Inc(nameRef);
Inc(ordinal);
end;
// exported symbol not found
if (Idx = -1) then
begin
SetLastError(ERROR_PROC_NOT_FOUND);
Exit;
end;
// name <-> ordinal number don't match
if (DWORD(Idx) > exportDir.NumberOfFunctions) then
begin
SetLastError(ERROR_PROC_NOT_FOUND);
Exit;
end;
// AddressOfFunctions contains the RVAs to the "real" functions {}
temp := Pointer(PByte(CodeBase) + exportDir.AddressOfFunctions + Idx*4);
Result := Pointer(PByte(CodeBase) + temp^);
end;
procedure MemoryFreeLibrary(Module: TMemoryModule); stdcall;
var
i: Integer;
DllEntry: TDllEntryProc;
mmodule: PMemoryModule;
begin
if Module = nil then Exit;
mmodule := PMemoryModule(Module);
if mmodule.Initialized then
begin
// notify library about detaching from process
@DllEntry := Pointer(PByte(mmodule.CodeBase) + mmodule.Headers.OptionalHeader.AddressOfEntryPoint);
DllEntry(HINST(mmodule.CodeBase), DLL_PROCESS_DETACH, nil);
end;
if Length(mmodule.Modules) <> 0 then
begin
// free previously opened libraries
for i := 0 to mmodule.NumModules - 1 do
if mmodule.Modules[i] <> 0 then
FreeLibrary_Internal(mmodule.Modules[i]);
SetLength(mmodule.Modules, 0);
end;
if mmodule.CodeBase <> nil then
// release memory of library
VirtualFree(mmodule.CodeBase, 0, MEM_RELEASE);
HeapFree(GetProcessHeap(), 0, mmodule);
end;
end.

171
contrib/Delphi_MemoryModule/MemoryModuleHook.pas Normal file
View File

@@ -0,0 +1,171 @@
// Unit that hooks LoadLibrary, GetProcAddress, FreeLibrary for MemoryModule
// to allow transparent DLL loading.
unit MemoryModuleHook;
interface
uses
Windows,
MemoryModule, FuncHook;
type
// Callback function that is called from LoadLibraryHook to determine
// an address of library data.
// lpLibFileName: name of library to load
// Returns:
// Pointer to library data; nil to bypass MemoryModule and use WinAPI
TGetLibPtrProc = function (lpLibFileName: PWideChar): Pointer;
function InstallHook(AGetLibPtrCallback: TGetLibPtrProc): Boolean;
function UninstallHook: Boolean;
implementation
var
HookInstalled: Boolean = False;
GetLibPtrCallback: TGetLibPtrProc;
LoadedModules: array of HMODULE;
CS: RTL_CRITICAL_SECTION;
LoadLibrary_Old: function (lpLibFileName: PWideChar): HMODULE; stdcall;
GetProcAddress_Old: function (hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall;
FreeLibrary_Old: function (hLibModule: HMODULE): BOOL; stdcall;
HI_LL, HI_GPA, HI_FL: THookInfo;
function IndexOfLoadedModule(hModule: HMODULE): Integer;
var i: Integer;
begin
EnterCriticalSection(CS);
try
for i := Low(LoadedModules) to High(LoadedModules) do
if LoadedModules[i] = hModule then
Exit(i);
Result := -1;
finally
LeaveCriticalSection(CS);
end;
end;
// Try to get library address and load it, run WinAPI routine otherwise.
function LoadLibraryHook(lpLibFileName: PWideChar): HMODULE; stdcall;
var
LibPtr: Pointer;
begin
Result := 0;
LibPtr := GetLibPtrCallback(lpLibFileName);
if LibPtr = nil then
begin
LoadLibrary_Old(lpLibFileName);
Exit;
end;
Result := HMODULE(MemoryLoadLibary(LibPtr));
if Result <> 0 then
try
EnterCriticalSection(CS);
SetLength(LoadedModules, Length(LoadedModules) + 1);
LoadedModules[Length(LoadedModules) - 1] := Result;
finally
LeaveCriticalSection(CS);
end;
end;
// If hModule was loaded via MM, run MM's routine. Otherwise, run WinAPI one.
function GetProcAddressHook(hModule: HMODULE; lpProcName: LPCSTR): FARPROC; stdcall;
begin
if IndexOfLoadedModule(hModule) <> -1 then
Result := FARPROC(MemoryGetProcAddress(TMemoryModule(hModule), lpProcName))
else
Result := GetProcAddress_Old(hModule, lpProcName);
end;
// If hLibModule was loaded via MM, run MM's routine. Otherwise, run WinAPI one.
function FreeLibraryHook(hLibModule: HMODULE): BOOL; stdcall;
var idx: Integer;
begin
idx := IndexOfLoadedModule(hLibModule);
if idx <> -1 then
begin
MemoryFreeLibrary(TMemoryModule(hLibModule));
Result := BOOL(True);
// Remove from the list
try
EnterCriticalSection(CS);
LoadedModules[idx] := 0;
if idx < Length(LoadedModules) - 1 then
Move(LoadedModules[idx + 1], LoadedModules[idx], (Length(LoadedModules) - idx + 1)*SizeOf(HMODULE));
SetLength(LoadedModules, Length(LoadedModules) - 1);
finally
LeaveCriticalSection(CS);
end;
end
else
Result := FreeLibrary_Old(hLibModule);
end;
function InstallHook(AGetLibPtrCallback: TGetLibPtrProc): Boolean;
begin
Result := False;
if not Assigned(AGetLibPtrCallback) then Exit;
EnterCriticalSection(CS);
try
if HookInstalled then Exit;
if not HookProcedure(False, HI_LL) or
not HookProcedure(False, HI_GPA) or
not HookProcedure(False, HI_FL) then Exit;
LoadLibrary_Old := HI_LL.OrigProc;
GetProcAddress_Old := HI_GPA.OrigProc;
FreeLibrary_Old := HI_FL.OrigProc;
HookInstalled := True;
GetLibPtrCallback := AGetLibPtrCallback;
Result := True;
finally
if not Result then
UninstallHook;
LeaveCriticalSection(CS);
end;
end;
function UninstallHook: Boolean;
begin
Result := False;
EnterCriticalSection(CS);
try
if not HookInstalled then Exit;
while Length(LoadedModules) > 0 do
FreeLibrary(LoadedModules[0]);
Result :=
UnhookProcedure(HI_LL) and
UnhookProcedure(HI_GPA) and
UnhookProcedure(HI_FL);
GetLibPtrCallback := nil;
HookInstalled := False;
finally
LeaveCriticalSection(CS);
end;
end;
initialization
InitializeCriticalSection(CS);
HI_LL.Init(@LoadLibrary, @LoadLibraryHook);
HI_GPA.Init(@GetProcAddress, @GetProcAddressHook);
HI_FL.Init(@FreeLibrary, @FreeLibraryHook);
finalization
UninstallHook;
DeleteCriticalSection(CS);
end.

69
contrib/Delphi_MemoryModule/README.md Normal file
View File

@@ -0,0 +1,69 @@
MemoryModule <20> loading DLL from memory (Delphi adaptation)
==========================================================
*This code is Delphi translation of MemoryModule.c file by [Joachim Bauch](https://github.com/fancycode/MemoryModule) with addition of two helper units that enable using MM engine completely transparently.*
*Resource loading and exe loading, custom functions, user data not implemented yet.*
*Tested under RAD Studio XE2 and XE6 32/64-bit, Lazarus 32-bit. Demo project included.*
Features in brief
-----------------
With the MemoryModule engine you can store all required DLLs inside your binary to keep it standalone. Additional hook units allow transparent using of MM engine thus allowing switching MM/WinAPI loading as well as enabling 3rd party dynamic-load DLL interfaces that are unaware of MM (tested with Interbase Express components and Firebird client library).
In other words, you can do things like this
```delphi
try
ms := TMemoryStream.Create;
ms.LoadFromFile(ParamStr(1));
ms.Position := 0;
lib := MemoryLoadLibary(ms.Memory);
ms.Free;
if lib = nil then Exit;
func := TNativeUIntFunc(MemoryGetProcAddress(lib, PAnsiChar(AnsiString(ParamStr(2)))));
if @func = nil then Exit;
WriteLn(func);
finally
MemoryFreeLibrary(lib);
end;
```
or even like this
```delphi
if not InstallHook(@GetLibPtrProc) then
begin
Writeln('Error installing hook');
Exit;
end;
try
ms := TMemoryStream.Create;
ms.LoadFromFile(ParamStr(1));
ms.Position := 0;
lib := Pointer(LoadLibrary(PChar(ParamStr(1))));
ms.Free;
if lib = nil then Exit;
func := TNativeUIntFunc(GetProcAddress(HMODULE(lib), PAnsiChar(AnsiString(ParamStr(2)))));
if @func = nil then Exit;
WriteLn(func);
finally
FreeLibrary(HMODULE(lib));
UninstallHook;
end;
```
See demo project for samples. Good testing sample of parameters is `%WinDir%\System32\KernelBase.dll` and `GetCurrentThread`. Note that `kernel32.dll` and some of the other Windows libraries couldn't be loaded with MM.
References
----------
* [Joahim's article](https://github.com/fancycode/MemoryModule/tree/master/doc)
* [TLS Callbacks](http://thelegendofrandom.com/blog/archives/2418)
* [PE description](https://code.google.com/p/corkami/wiki/PE)