btmemorymodule.pas

TSevenZipVCL v.0.73 By Rainer Geigenberger. Component / Wrapper to use the 7zip dll. Easy to us

unit BTMemoryModule;

 {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  * Memory DLL loading code                                                 *
  * ------------------------                                                *
  *                                                                         *
  * MemoryModule "Conversion to Delphi"                                     *
  * Copyright (c) 2005 - 2006 by Martin Offenwanger / [e-mail]     *
  * http://www.dsplayer.de                                                  *
  *                                                                         *
  * Original C++ Code "MemoryModule Version 0.0.1"                          *
  * Copyright (c) 2004- 2006 by Joachim Bauch / [e-mail]       *
  * http://www.joachim-bauch.de                                             *
  *                                                                         *
  * This library is free software; you can redistribute it and/or           *
  * modify it under the terms of the GNU Lesser General Public              *
  * License as published by the Free Software Foundation; either            *
  * version 2.1 of the License, or (at your option) any later version.      *
  *                                                                         *
  * This library is distributed in the hope that it will be useful,         *
  * but WITHOUT ANY WARRANTY; without even the implied warranty of          *
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       *
  * Lesser General Public License for more details.                         *
  *                                                                         *
  * You should have received a copy of the GNU Lesser General Public        *
  * License along with this library; if not, write to the Free Software     *
  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *
  *                                                                         *
  * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{
@author(Martin Offenwanger: [e-mail])
@created(Mar 20, 2005)
@lastmod(Sep 27, 2005)
}

interface

uses
  // Borland Run-time Library
  Windows;

   {++++++++++++++++++++++++++++++++++++++
    ***  MemoryModule Type Definition  ***
    --------------------------------------}
type
  PBTMemoryModule = ^TBTMemoryModule;
  _BT_MEMORY_MODULE = packed record
    headers: PImageNtHeaders;
    codeBase: Pointer;
    modules: Pointer;
    numModules: integer;
    initialized: boolean;
  end;
{$EXTERNALSYM _BT_MEMORY_MODULE}
  TBTMemoryModule = _BT_MEMORY_MODULE;
  BT_MEMORY_MODULE = _BT_MEMORY_MODULE;
{$EXTERNALSYM BT_MEMORY_MODULE}


   {++++++++++++++++++++++++++++++++++++++++++++++++++
    ***  Memory DLL loading functions Declaration  ***
    --------------------------------------------------}

// return value is nil if function fails
function BTMemoryLoadLibary(var f_data: Pointer; const f_size: int64): PBTMemoryModule; stdcall;
// return value is nil if function fails
function BTMemoryGetProcAddress(var f_module: PBTMemoryModule; const f_name: PChar): Pointer; stdcall;
// free module
procedure BTMemoryFreeLibrary(var f_module: PBTMemoryModule); stdcall;
// returns last error
function BTMemoryGetLastError: string; stdcall;


implementation

uses
  // Borland Run-time Library
  SysUtils;

   {+++++++++++++++++++++++++++++++++++
    ***  Dll EntryPoint Definition  ***
    -----------------------------------}
type
  TDllEntryProc = function(hinstdll: THandle; fdwReason: DWORD; lpReserved: Pointer): BOOL; stdcall;


   {++++++++++++++++++++++++++++++++++++++++
    ***  Missing Windows API Definitions ***
    ----------------------------------------}

  PImageBaseRelocation = ^TImageBaseRelocation;
  _IMAGE_BASE_RELOCATION = packed record
    VirtualAddress: DWORD;
    SizeOfBlock: DWORD;
  end;
{$EXTERNALSYM _IMAGE_BASE_RELOCATION}
  TImageBaseRelocation = _IMAGE_BASE_RELOCATION;
  IMAGE_BASE_RELOCATION = _IMAGE_BASE_RELOCATION;
{$EXTERNALSYM IMAGE_BASE_RELOCATION}

  PImageImportDescriptor = ^TImageImportDescriptor;
  _IMAGE_IMPORT_DESCRIPTOR = packed record
    OriginalFirstThunk: DWORD;
    TimeDateStamp: DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD;
  end;
{$EXTERNALSYM _IMAGE_IMPORT_DESCRIPTOR}
  TImageImportDescriptor = _IMAGE_IMPORT_DESCRIPTOR;
  IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR;
{$EXTERNALSYM IMAGE_IMPORT_DESCRIPTOR}

  PImageImportByName = ^TImageImportByName;
  _IMAGE_IMPORT_BY_NAME = packed record
    Hint: Word;
    Name: array[0..255] of Byte; // original: "Name: array [0..0] of Byte;"
  end;
{$EXTERNALSYM _IMAGE_IMPORT_BY_NAME}
  TImageImportByName = _IMAGE_IMPORT_BY_NAME;
  IMAGE_IMPORT_BY_NAME = _IMAGE_IMPORT_BY_NAME;
{$EXTERNALSYM IMAGE_IMPORT_BY_NAME}

const
  IMAGE_SIZEOF_BASE_RELOCATION = 8;
{$EXTERNALSYM IMAGE_SIZEOF_BASE_RELOCATION}
  IMAGE_REL_BASED_HIGHLOW = 3;
{$EXTERNALSYM IMAGE_REL_BASED_HIGHLOW}
  IMAGE_ORDINAL_FLAG32 = DWORD($80000000);
{$EXTERNALSYM IMAGE_ORDINAL_FLAG32}

var
  lastErrStr: string;


   {+++++++++++++++++++++++++++++++++++++++++++++++++++++
    ***  Memory DLL loading functions Implementation  ***
    -----------------------------------------------------}

function BTMemoryGetLastError: string; stdcall;
begin
  Result := lastErrStr;
end;

function GetFieldOffset(const Struc; const Field): Cardinal; stdcall;
begin
  Result := Cardinal(@Field) - Cardinal(@Struc);
end;

function GetImageFirstSection(NtHeader: PImageNtHeaders): PImageSectionHeader; stdcall;
begin
  Result := PImageSectionHeader(Cardinal(NtHeader) +
    GetFieldOffset(NtHeader^, NtHeader^.OptionalHeader) +
    NtHeader^.FileHeader.SizeOfOptionalHeader);
end;

function GetHeaderDictionary(f_module: PBTMemoryModule; f_idx: integer): PImageDataDirectory; stdcall;
begin
  Result := PImageDataDirectory(@(f_module.headers.OptionalHeader.DataDirectory[f_idx]));
end;

function GetImageOrdinal(Ordinal: DWORD): Word; stdcall;
begin
  Result := Ordinal and $FFFF;
end;

function GetImageSnapByOrdinal(Ordinal: DWORD): Boolean; stdcall;
begin
  Result := ((Ordinal and IMAGE_ORDINAL_FLAG32) <> 0);
end;

procedure CopySections(const f_data: Pointer; const f_old_headers: TImageNtHeaders; f_module: PBTMemoryModule); stdcall;
var
  l_size, i: integer;
  l_codebase: Pointer;
  l_dest: Pointer;
  l_section: PImageSectionHeader;
begin
  l_codebase := f_module.codeBase;
  l_section := GetImageFirstSection(f_module.headers);
  for i := 0 to f_module.headers.FileHeader.NumberOfSections - 1 do begin
    // section doesn't contain data in the dll itself, but may define
    // uninitialized data
    if (l_section.SizeOfRawData = 0) then begin
      l_size := f_old_headers.OptionalHeader.SectionAlignment;
      if l_size > 0 then begin
        l_dest := VirtualAlloc(Pointer(Cardinal(l_codebase) + l_section.VirtualAddress), l_size, MEM_COMMIT, PAGE_READWRITE);
        l_section.Misc.PhysicalAddress := cardinal(l_dest);
        ZeroMemory(l_dest, l_size);
      end;
      inc(longword(l_section), sizeof(TImageSectionHeader));
      // Continue with the nex loop
      Continue;
    end;
    // commit memory block and copy data from dll
    l_dest := VirtualAlloc(Pointer(Cardinal(l_codebase) + l_section.VirtualAddress), l_section.SizeOfRawData, MEM_COMMIT, PAGE_READWRITE);
    CopyMemory(l_dest, Pointer(longword(f_data) + l_section.PointerToRawData), l_section.SizeOfRawData);
    l_section.Misc.PhysicalAddress := cardinal(l_dest);
    // IMAGE_SIZEOF_SECTION_HEADER
    inc(longword(l_section), sizeof(TImageSectionHeader));
  end;
end;

procedure PerformBaseRelocation(f_module: PBTMemoryModule; f_delta: Cardinal); stdcall;
var
  l_i: Cardinal;
  l_codebase: Pointer;
  l_directory: PImageDataDirectory;
  l_relocation: PImageBaseRelocation;
  l_dest: Pointer;
  l_relInfo: ^Word;
  l_patchAddrHL: ^DWord;
  l_type, l_offset: integer;
begin
  l_codebase := f_module.codeBase;
  l_directory := GetHeaderDictionary(f_module, IMAGE_DIRECTORY_ENTRY_BASERELOC);
  if l_directory.Size > 0 then begin
    l_relocation := PImageBaseRelocation(Cardinal(l_codebase) + l_directory.VirtualAddress);
    while l_relocation.VirtualAddress > 0 do begin
      l_dest := Pointer((Cardinal(l_codebase) + l_relocation.VirtualAddress));
      l_relInfo := Pointer(Cardinal(l_relocation) + IMAGE_SIZEOF_BASE_RELOCATION);
      for l_i := 0 to (trunc(((l_relocation.SizeOfBlock - IMAGE_SIZEOF_BASE_RELOCATION) / 2)) - 1) do begin
        // the upper 4 bits define the type of relocation
        l_type := (l_relInfo^ shr 12);
        // the lower 12 bits define the offset
        l_offset := l_relInfo^ and $FFF;
        //showmessage(inttostr(l_relInfo^));
        if l_type = IMAGE_REL_BASED_HIGHLOW then begin
          // change complete 32 bit address
          l_patchAddrHL := Pointer(Cardinal(l_dest) + Cardinal(l_offset));
          l_patchAddrHL^ := l_patchAddrHL^ + f_delta;
        end;
        inc(l_relInfo);
      end;
      l_relocation := Pointer(cardinal(l_relocation) + l_relocation.SizeOfBlock);
    end;
  end;
end;

function BuildImportTable(f_module: PBTMemoryModule): boolean; stdcall;
var
  l_codeBase: Pointer;
  l_directory: PImageDataDirectory;
  l_importDesc: PImageImportDescriptor;
  l_thunkRef, l_funcRef: ^DWORD;
  l_handle: HMODULE;
  l_temp: integer;
  l_thunkData: TImageImportByName;
begin
  Result := true;
  l_codeBase := f_module.codeBase;
  l_directory := GetHeaderDictionary(f_module, IMAGE_DIRECTORY_ENTRY_IMPORT);
  if (l_directory.Size > 0) then begin
    l_importDesc := PImageImportDescriptor(Cardinal(l_codeBase) + l_directory.VirtualAddress);
    while (not IsBadReadPtr(l_importDesc, sizeof(TImageImportDescriptor))) and (l_importDesc.Name <> 0) do begin
      l_handle := LoadLibrary(PChar(Cardinal(l_codeBase) + l_importDesc.Name));
      if (l_handle = INVALID_HANDLE_VALUE) then begin
        lastErrStr := 'BuildImportTable: can''t load library: ' + PChar(Cardinal(l_codeBase) + l_importDesc.Name);
        Result := false;
        exit;
      end;
      // ReallocMemory crashes if "f_module.modules = nil"
      if f_module.modules = nil then
        f_module.modules := AllocMem(1);
      f_module.modules := ReallocMemory(f_module.modules, ((f_module.numModules + 1) * (sizeof(HMODULE))));
      if f_module.modules = nil then begin
        lastErrStr := 'BuildImportTable: ReallocMemory failed';
        result := false;
        exit;
      end;
      // module->modules[module->numModules++] = handle;
      l_temp := (sizeof(cardinal) * (f_module.numModules));
      inc(Cardinal(f_module.modules), l_temp);
      cardinal(f_module.modules^) := l_handle;
      dec(Cardinal(f_module.modules), l_temp);
      f_module.numModules := f_module.numModules + 1;
      if l_importDesc.OriginalFirstThunk <> 0 then begin
        l_thunkRef := Pointer(Cardinal(l_codeBase) + l_importDesc.OriginalFirstThunk);
        l_funcRef := Pointer(Cardinal(l_codeBase) + l_importDesc.FirstThunk);
      end else begin
        // no hint table
        l_thunkRef := Pointer(Cardinal(l_codeBase) + l_importDesc.FirstThunk);
        l_funcRef := Pointer(Cardinal(l_codeBase) + l_importDesc.FirstThunk);
      end;
      while l_thunkRef^ <> 0 do begin
        if GetImageSnapByOrdinal(l_thunkRef^) then
          l_funcRef^ := Cardinal(GetProcAddress(l_handle, PChar(GetImageOrdinal(l_thunkRef^))))
        else begin
          CopyMemory(@l_thunkData, Pointer(Cardinal(l_codeBase) + l_thunkRef^), sizeof(TImageImportByName));
          l_funcRef^ := Cardinal(GetProcAddress(l_handle, PChar(@(l_thunkData.Name))));
        end;
        if l_funcRef^ = 0 then begin
          lastErrStr := 'BuildImportTable: GetProcAddress failed';
          result := false;
          break;
        end;
        inc(l_funcRef);
        inc(l_thunkRef);
      end;
      inc(longword(l_importDesc), sizeof(TImageImportDescriptor));
    end;
  end;
end;

function GetSectionProtection(SC: cardinal): cardinal; stdcall;
//SC