paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 10:39:29 +02:00
Code Issues Packages Projects Releases Wiki Activity
f4f3ae84d0
fpc/rtl/inc/exeinfo.pp
peter f4f3ae84d0 * AllowDirectorySeparators and AllowDriveSeparators typed constants 
added to allow customization of path and directory parsing in the rtl
  * Use the new sets instead of the hardcoded / and \

git-svn-id: trunk@10105 -
2008-01-29 23:04:56 +00:00

1087 lines
27 KiB
ObjectPascal
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 2008 by Peter Vreman
Executable file reading functions
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program 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.
**********************************************************************}
unit exeinfo;
interface
{$mode objfpc}
{$S-}
type
TExeFile=record
f : file;
// cached filesize
size : int64;
isopen : boolean;
nsects : longint;
sechdrofs,
secstrofs : ptruint;
processaddress : ptruint;
FunctionRelative: boolean;
filename : string;
// Allocate static buffer for reading data
buf : array[0..4095] of byte;
bufsize,
bufcnt : longint;
end;
function OpenExeFile(out e:TExeFile;const fn:string):boolean;
function FindExeSection(var e:TExeFile;const secname:string;out secofs,seclen:longint):boolean;
function CloseExeFile(var e:TExeFile):boolean;
function ReadDebugLink(var e:TExeFile;out dbgfn:string):boolean;
implementation
uses
strings;
{****************************************************************************
Executable Loaders
****************************************************************************}
{$if defined(netbsd) or defined(freebsd) or defined(linux) or defined(sunos)}
{$ifdef cpu64}
{$define ELF64}
{$else}
{$define ELF32}
{$endif}
{$endif}
{$if defined(win32) or defined(wince)}
{$define PE32}
{$endif}
{$if defined(win64)}
{$define PE32PLUS}
{$endif}
{$ifdef netwlibc}
{$define netware}
{$endif}
{$IFDEF OS2}
{$DEFINE EMX}
{$ENDIF OS2}
{****************************************************************************
DOS Stub
****************************************************************************}
{$if defined(EMX) or defined(PE32) or defined(PE32PLUS)}
type
tdosheader = packed record
e_magic : word;
e_cblp : word;
e_cp : word;
e_crlc : word;
e_cparhdr : word;
e_minalloc : word;
e_maxalloc : word;
e_ss : word;
e_sp : word;
e_csum : word;
e_ip : word;
e_cs : word;
e_lfarlc : word;
e_ovno : word;
e_res : array[0..3] of word;
e_oemid : word;
e_oeminfo : word;
e_res2 : array[0..9] of word;
e_lfanew : longint;
end;
{$endif EMX or PE32 or PE32PLUS}
{****************************************************************************
NLM
****************************************************************************}
{$ifdef netware}
const SIZE_OF_NLM_INTERNAL_FIXED_HEADER = 130;
SIZE_OF_NLM_INTERNAL_VERSION_HEADER = 32;
SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER = 124;
function loadNetwareNLM:boolean;
var valid : boolean;
name : string;
StabLength,
StabStrLength,
alignAmount,
hdrLength,
dataOffset,
dataLength : longint;
function getByte:byte;
begin
BlockRead (f,getByte,1);
end;
procedure Skip (bytes : longint);
var i : longint;
begin
for i := 1 to bytes do getbyte;
end;
function getLString : String;
var Res:string;
begin
blockread (F, res, 1);
if length (res) > 0 THEN
blockread (F, res[1], length (res));
getbyte;
getLString := res;
end;
function getFixString (Len : byte) : string;
var i : byte;
begin
getFixString := '';
for I := 1 to Len do
getFixString := getFixString + char (getbyte);
end;
function get0String : string;
var c : char;
begin
get0String := '';
c := char (getbyte);
while (c <> #0) do
begin
get0String := get0String + c;
c := char (getbyte);
end;
end;
function getword : word;
begin
blockread (F, getword, 2);
end;
function getint32 : longint;
begin
blockread (F, getint32, 4);
end;
begin
processaddress := 0;
LoadNetwareNLM:=false;
stabofs:=-1;
stabstrofs:=-1;
{ read and check header }
Skip (SIZE_OF_NLM_INTERNAL_FIXED_HEADER);
getLString; // NLM Description
getInt32; // Stacksize
getInt32; // Reserved
skip(5); // old Thread Name
getLString; // Screen Name
getLString; // Thread Name
hdrLength := -1;
dataOffset := -1;
dataLength := -1;
valid := true;
repeat
name := getFixString (8);
if (name = 'VeRsIoN#') then
begin
Skip (SIZE_OF_NLM_INTERNAL_VERSION_HEADER-8);
end else
if (name = 'CoPyRiGh') then
begin
getword; // T=
getLString; // Copyright String
end else
if (name = 'MeSsAgEs') then
begin
skip (SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER - 8);
end else
if (name = 'CuStHeAd') then
begin
hdrLength := getInt32;
dataOffset := getInt32;
dataLength := getInt32;
Skip (8); // dataStamp
Valid := false;
end else
Valid := false;
until not valid;
if (hdrLength = -1) or (dataOffset = -1) or (dataLength = -1) then
exit;
(* The format of the section information is:
null terminated section name
zeroes to adjust to 4 byte boundary
4 byte section data file pointer
4 byte section size *)
Seek (F, dataOffset);
stabOfs := 0;
stabStrOfs := 0;
Repeat
Name := Get0String;
alignAmount := 4 - ((length (Name) + 1) MOD 4);
Skip (alignAmount);
if (Name = '.stab') then
begin
stabOfs := getInt32;
stabLength := getInt32;
stabcnt:=stabLength div sizeof(tstab);
end else
if (Name = '.stabstr') then
begin
stabStrOfs := getInt32;
stabStrLength := getInt32;
end else
Skip (8);
until (Name = '') or ((StabOfs <> 0) and (stabStrOfs <> 0));
Seek (F,stabOfs);
//if (StabOfs = 0) then __ConsolePrintf ('StabOfs = 0');
//if (StabStrOfs = 0) then __ConsolePrintf ('StabStrOfs = 0');
LoadNetwareNLM := ((stabOfs > 0) and (stabStrOfs > 0));
end;
{$endif}
{****************************************************************************
COFF
****************************************************************************}
{$if defined(PE32) or defined(PE32PLUS) or defined(GO32V2)}
type
tcoffsechdr=packed record
name : array[0..7] of char;
vsize : longint;
rvaofs : longint;
datalen : longint;
datapos : longint;
relocpos : longint;
lineno1 : longint;
nrelocs : word;
lineno2 : word;
flags : longint;
end;
coffsymbol=packed record
name : array[0..3] of char; { real is [0..7], which overlaps the strofs ! }
strofs : longint;
value : longint;
section : smallint;
empty : word;
typ : byte;
aux : byte;
end;
function FindSectionCoff(var e:TExeFile;const asecname:string;out secofs,seclen:longint):boolean;
var
i : longint;
sechdr : tcoffsechdr;
secname : string;
secnamebuf : array[0..255] of char;
code,
oldofs,
bufsize : longint;
strofs : cardinal;
begin
result:=false;
{ read section info }
seek(e.f,e.sechdrofs);
for i:=1 to e.nsects do
begin
blockread(e.f,sechdr,sizeof(sechdr),bufsize);
move(sechdr.name,secnamebuf,8);
secnamebuf[8]:=#0;
secname:=strpas(secnamebuf);
if secname[1]='/' then
begin
Val(Copy(secname,2,8),strofs,code);
if code=0 then
begin
fillchar(secnamebuf,sizeof(secnamebuf),0);
oldofs:=filepos(e.f);
seek(e.f,e.secstrofs+strofs);
blockread(e.f,secnamebuf,sizeof(secnamebuf),bufsize);
seek(e.f,oldofs);
secname:=strpas(secnamebuf);
end
else
secname:='';
end;
if asecname=secname then
begin
secofs:=sechdr.datapos;
seclen:=sechdr.datalen;
result:=true;
exit;
end;
end;
end;
{$endif PE32 or PE32PLUS or GO32V2}
{$ifdef go32v2}
function OpenGo32Coff(var e:TExeFile):boolean;
type
tgo32coffheader=packed record
mach : word;
nsects : word;
time : longint;
sympos : longint;
syms : longint;
opthdr : word;
flag : word;
other : array[0..27] of byte;
end;
var
coffheader : tgo32coffheader;
begin
result:=false;
{ read and check header }
if e.size<2048+sizeof(coffheader) then
exit;
seek(e.f,2048);
blockread(e.f,coffheader,sizeof(coffheader));
if coffheader.mach<>$14c then
exit;
e.sechdrofs:=filepos(e.f);
e.nsects:=coffheader.nsects;
e.secstrofs:=coffheader.sympos+coffheader.syms*sizeof(coffsymbol)+4;
if e.secstrofs>e.size then
exit;
result:=true;
end;
{$endif Go32v2}
{$ifdef PE32}
function OpenPeCoff(var e:TExeFile):boolean;
type
tpeheader = packed record
PEMagic : longint;
Machine : word;
NumberOfSections : word;
TimeDateStamp : longint;
PointerToSymbolTable : longint;
NumberOfSymbols : longint;
SizeOfOptionalHeader : word;
Characteristics : word;
Magic : word;
MajorLinkerVersion : byte;
MinorLinkerVersion : byte;
SizeOfCode : longint;
SizeOfInitializedData : longint;
SizeOfUninitializedData : longint;
AddressOfEntryPoint : longint;
BaseOfCode : longint;
BaseOfData : longint;
ImageBase : longint;
SectionAlignment : longint;
FileAlignment : longint;
MajorOperatingSystemVersion : word;
MinorOperatingSystemVersion : word;
MajorImageVersion : word;
MinorImageVersion : word;
MajorSubsystemVersion : word;
MinorSubsystemVersion : word;
Reserved1 : longint;
SizeOfImage : longint;
SizeOfHeaders : longint;
CheckSum : longint;
Subsystem : word;
DllCharacteristics : word;
SizeOfStackReserve : longint;
SizeOfStackCommit : longint;
SizeOfHeapReserve : longint;
SizeOfHeapCommit : longint;
LoaderFlags : longint;
NumberOfRvaAndSizes : longint;
DataDirectory : array[1..$80] of byte;
end;
var
dosheader : tdosheader;
peheader : tpeheader;
begin
result:=false;
{ read and check header }
if e.size<sizeof(dosheader) then
exit;
blockread(e.f,dosheader,sizeof(tdosheader));
seek(e.f,dosheader.e_lfanew);
blockread(e.f,peheader,sizeof(tpeheader));
if peheader.pemagic<>$4550 then
exit;
e.sechdrofs:=filepos(e.f);
e.nsects:=peheader.NumberOfSections;
e.secstrofs:=peheader.PointerToSymbolTable+peheader.NumberOfSymbols*sizeof(coffsymbol)+4;
if e.secstrofs>e.size then
exit;
result:=true;
end;
{$endif PE32}
{$ifdef PE32PLUS}
function OpenPePlusCoff(var e:TExeFile):boolean;
type
tpeheader = packed record
PEMagic : longint;
Machine : word;
NumberOfSections : word;
TimeDateStamp : longint;
PointerToSymbolTable : longint;
NumberOfSymbols : longint;
SizeOfOptionalHeader : word;
Characteristics : word;
Magic : word;
MajorLinkerVersion : byte;
MinorLinkerVersion : byte;
SizeOfCode : longint;
SizeOfInitializedData : longint;
SizeOfUninitializedData : longint;
AddressOfEntryPoint : longint;
BaseOfCode : longint;
BaseOfData : longint;
ImageBase : longint;
SectionAlignment : longint;
FileAlignment : longint;
MajorOperatingSystemVersion : word;
MinorOperatingSystemVersion : word;
MajorImageVersion : word;
MinorImageVersion : word;
MajorSubsystemVersion : word;
MinorSubsystemVersion : word;
Reserved1 : longint;
SizeOfImage : longint;
SizeOfHeaders : longint;
CheckSum : longint;
Subsystem : word;
DllCharacteristics : word;
SizeOfStackReserve : int64;
SizeOfStackCommit : int64;
SizeOfHeapReserve : int64;
SizeOfHeapCommit : int64;
LoaderFlags : longint;
NumberOfRvaAndSizes : longint;
DataDirectory : array[1..$80] of byte;
end;
var
dosheader : tdosheader;
peheader : tpeheader;
begin
result:=false;
{ read and check header }
if E.Size<sizeof(dosheader) then
exit;
blockread(E.F,dosheader,sizeof(tdosheader));
seek(E.F,dosheader.e_lfanew);
blockread(E.F,peheader,sizeof(tpeheader));
if peheader.pemagic<>$4550 then
exit;
e.sechdrofs:=filepos(e.f);
e.nsects:=peheader.NumberOfSections;
e.secstrofs:=peheader.PointerToSymbolTable+peheader.NumberOfSymbols*sizeof(coffsymbol)+4;
if e.secstrofs>e.size then
exit;
result:=true;
end;
{$endif PE32PLUS}
{****************************************************************************
AOUT
****************************************************************************}
{$IFDEF EMX}
type
TEmxHeader = packed record
Version: array [1..16] of char;
Bound: word;
AoutOfs: longint;
Options: array [1..42] of char;
end;
TAoutHeader = packed record
Magic: word;
Machine: byte;
Flags: byte;
TextSize: longint;
DataSize: longint;
BssSize: longint;
SymbSize: longint;
EntryPoint: longint;
TextRelocSize: longint;
DataRelocSize: longint;
end;
const
StartPageSize = $1000;
var
DosHeader: TDosHeader;
EmxHeader: TEmxHeader;
AoutHeader: TAoutHeader;
StabOfs: PtrUInt;
S4: string [4];
function OpenEMXaout (var E: TExeFile): boolean;
begin
OpenEMXaout := false;
{ GDB after 4.18 uses offset to function begin
in text section but OS/2 version still uses 4.16 PM }
E.FunctionRelative := false;
{ read and check header }
if E.Size > SizeOf (DosHeader) then
begin
BlockRead (E.F, DosHeader, SizeOf (TDosHeader));
if E.Size > DosHeader.e_cparhdr shl 4 + SizeOf (TEmxHeader) then
begin
Seek (E.F, DosHeader.e_cparhdr shl 4);
BlockRead (E.F, EmxHeader, SizeOf (TEmxHeader));
S4 [0] := #4;
Move (EmxHeader.Version, S4 [1], 4);
if (S4 = 'emx ') and
(E.Size > EmxHeader.AoutOfs + SizeOf (TAoutHeader)) then
begin
Seek (E.F, EmxHeader.AoutOfs);
BlockRead (E.F, AoutHeader, SizeOf (TAoutHeader));
if AOutHeader.Magic = $10B then
StabOfs := StartPageSize
else
StabOfs := EmxHeader.AoutOfs + SizeOf (TAoutHeader);
StabOfs := StabOfs
+ AoutHeader.TextSize
+ AoutHeader.DataSize
+ AoutHeader.TextRelocSize
+ AoutHeader.DataRelocSize;
if E.Size > StabOfs + AoutHeader.SymbSize then
OpenEMXaout := true;
end;
end;
end;
end;
function FindSectionEMXaout (var E: TExeFile; const ASecName: string;
out SecOfs, SecLen: longint): boolean;
begin
FindSectionEMXaout := false;
if ASecName = '.stab' then
begin
SecOfs := StabOfs;
SecLen := AoutHeader.SymbSize;
FindSectionEMXaout := true;
end else
if ASecName = '.stabstr' then
begin
SecOfs := StabOfs + AoutHeader.SymbSize;
SecLen := E.Size - Pred (SecOfs);
FindSectionEMXaout := true;
end;
end;
{$ENDIF EMX}
{****************************************************************************
ELF
****************************************************************************}
{$if defined(ELF32) or defined(BEOS)}
type
telfheader=packed record
magic0123 : longint;
file_class : byte;
data_encoding : byte;
file_version : byte;
padding : array[$07..$0f] of byte;
e_type : word;
e_machine : word;
e_version : longword;
e_entry : longword; // entrypoint
e_phoff : longword; // program header offset
e_shoff : longword; // sections header offset
e_flags : longword;
e_ehsize : word; // elf header size in bytes
e_phentsize : word; // size of an entry in the program header array
e_phnum : word; // 0..e_phnum-1 of entrys
e_shentsize : word; // size of an entry in sections header array
e_shnum : word; // 0..e_shnum-1 of entrys
e_shstrndx : word; // index of string section header
end;
telfsechdr=packed record
sh_name : longword;
sh_type : longword;
sh_flags : longword;
sh_addr : longword;
sh_offset : longword;
sh_size : longword;
sh_link : longword;
sh_info : longword;
sh_addralign : longword;
sh_entsize : longword;
end;
{$endif ELF32 or BEOS}
{$ifdef ELF64}
type
telfheader=packed record
magic0123 : longint;
file_class : byte;
data_encoding : byte;
file_version : byte;
padding : array[$07..$0f] of byte;
e_type : word;
e_machine : word;
e_version : longword;
e_entry : int64; // entrypoint
e_phoff : int64; // program header offset
e_shoff : int64; // sections header offset
e_flags : longword;
e_ehsize : word; // elf header size in bytes
e_phentsize : word; // size of an entry in the program header array
e_phnum : word; // 0..e_phnum-1 of entrys
e_shentsize : word; // size of an entry in sections header array
e_shnum : word; // 0..e_shnum-1 of entrys
e_shstrndx : word; // index of string section header
end;
type
telfsechdr=packed record
sh_name : longword;
sh_type : longword;
sh_flags : int64;
sh_addr : int64;
sh_offset : int64;
sh_size : int64;
sh_link : longword;
sh_info : longword;
sh_addralign : int64;
sh_entsize : int64;
end;
{$endif ELF64}
{$if defined(ELF32) or defined(ELF64) or defined(BEOS)}
function OpenElf(var e:TExeFile):boolean;
var
elfheader : telfheader;
elfsec : telfsechdr;
begin
result:=false;
{ read and check header }
if e.size<sizeof(telfheader) then
exit;
blockread(e.f,elfheader,sizeof(telfheader));
if elfheader.magic0123<>{$ifdef ENDIAN_LITTLE}$464c457f{$else}$7f454c46{$endif} then
exit;
if elfheader.e_shentsize<>sizeof(telfsechdr) then
exit;
{ read section names }
seek(e.f,elfheader.e_shoff+elfheader.e_shstrndx*cardinal(sizeof(telfsechdr)));
blockread(e.f,elfsec,sizeof(telfsechdr));
e.secstrofs:=elfsec.sh_offset;
e.sechdrofs:=elfheader.e_shoff;
e.nsects:=elfheader.e_shnum;
result:=true;
end;
function FindSectionElf(var e:TExeFile;const asecname:string;out secofs,seclen:longint):boolean;
var
elfsec : telfsechdr;
secname : string;
secnamebuf : array[0..255] of char;
oldofs,
bufsize,i : longint;
begin
result:=false;
seek(e.f,e.sechdrofs);
for i:=1 to e.nsects do
begin
blockread(e.f,elfsec,sizeof(telfsechdr));
fillchar(secnamebuf,sizeof(secnamebuf),0);
oldofs:=filepos(e.f);
seek(e.f,e.secstrofs+elfsec.sh_name);
blockread(e.f,secnamebuf,sizeof(secnamebuf),bufsize);
seek(e.f,oldofs);
secname:=strpas(secnamebuf);
if asecname=secname then
begin
secofs:=elfsec.sh_offset;
seclen:=elfsec.sh_size;
result:=true;
exit;
end;
end;
end;
{$endif ELF32 or ELF64 or BEOS}
{$ifdef beos}
{$i ptypes.inc}
type
// Descriptive formats
status_t = Longint;
team_id = Longint;
image_id = Longint;
{ image types }
const
B_APP_IMAGE = 1;
B_LIBRARY_IMAGE = 2;
B_ADD_ON_IMAGE = 3;
B_SYSTEM_IMAGE = 4;
type
image_info = packed record
id : image_id;
_type : longint;
sequence: longint;
init_order: longint;
init_routine: pointer;
term_routine: pointer;
device: dev_t;
node: ino_t;
name: array[0..MAXPATHLEN-1] of char;
{ name: string[255];
name2: string[255];
name3: string[255];
name4: string[255];
name5: string[5];
}
text: pointer;
data: pointer;
text_size: longint;
data_size: longint;
end;
function get_next_image_info(team: team_id; var cookie:longint; var info:image_info; size: size_t) : status_t;cdecl; external 'root' name '_get_next_image_info';
function OpenElf32Beos(var e:TExeFile):boolean;
var
cookie : longint;
info : image_info;
begin
// The only BeOS specific part is setting the processaddress
cookie := 0;
fillchar(info, sizeof(image_info), 0);
get_next_image_info(0,cookie,info,sizeof(info));
if (info._type = B_APP_IMAGE) then
e.processaddress := cardinal(info.text)
else
e.processaddress := 0;
Result := OpenElf(e);
end;
{$endif beos}
{****************************************************************************
MACHO
****************************************************************************}
{$ifdef darwin}
type
MachoFatHeader= packed record
magic: longint;
nfatarch: longint;
end;
MachoHeader=packed record
magic: longword;
cpu_type_t: longint;
cpu_subtype_t: longint;
filetype: longint;
ncmds: longint;
sizeofcmds: longint;
flags: longint;
end;
cmdblock=packed record
cmd: longint;
cmdsize: longint;
end;
symbSeg=packed record
symoff : longint;
nsyms : longint;
stroff : longint;
strsize: longint;
end;
tstab=packed record
strpos : longint;
ntype : byte;
nother : byte;
ndesc : word;
nvalue : dword;
end;
function OpenMachO32PPC(var e:TExeFile):boolean;
var
mh:MachoHeader;
begin
result:= false;
if e.size<sizeof(mh) then
exit;
blockread (e.f, mh, sizeof(mh));
e.sechdrofs:=filepos(e.f);
e.nsects:=mh.ncmds;
result:=true;
end;
function FindSectionMachO32PPC(var e:TExeFile;const asecname:string;out secofs,seclen:longint):boolean;
var
i: longint;
block:cmdblock;
symbolsSeg: symbSeg;
begin
seek(e.f,e.sechdrofs);
for i:= 1 to e.nsects do
begin
blockread (e.f, block, sizeof(block));
if block.cmd = $2 then
begin
blockread (e.f, symbolsSeg, sizeof(symbolsSeg));
if asecname='.stab' then
begin
secofs:=symbolsSeg.symoff;
{ the caller will divide again by sizeof(tstab) }
seclen:=symbolsSeg.nsyms*sizeof(tstab);
end
else if asecname='.stabstr' then
begin
secofs:=symbolsSeg.stroff;
seclen:=symbolsSeg.strsize;
end;
result:=true;
exit;
end;
Seek(e.f, FilePos (e.f) + block.cmdsize - sizeof(block));
end;
end;
{$endif darwin}
{****************************************************************************
CRC
****************************************************************************}
var
Crc32Tbl : array[0..255] of cardinal;
procedure MakeCRC32Tbl;
var
crc : cardinal;
i,n : integer;
begin
for i:=0 to 255 do
begin
crc:=i;
for n:=1 to 8 do
if (crc and 1)<>0 then
crc:=(crc shr 1) xor cardinal($edb88320)
else
crc:=crc shr 1;
Crc32Tbl[i]:=crc;
end;
end;
Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:Integer):cardinal;
var
i : integer;
p : pchar;
begin
if Crc32Tbl[1]=0 then
MakeCrc32Tbl;
p:=@InBuf;
result:=not InitCrc;
for i:=1 to InLen do
begin
result:=Crc32Tbl[byte(result) xor byte(p^)] xor (result shr 8);
inc(p);
end;
result:=not result;
end;
{****************************************************************************
Generic Executable Open/Close
****************************************************************************}
type
TOpenProc=function(var e:TExeFile):boolean;
TFindSectionProc=function(var e:TExeFile;const asecname:string;out secofs,seclen:longint):boolean;
TExeProcRec=record
openproc : TOpenProc;
findproc : TFindSectionProc;
end;
const
ExeProcs : TExeProcRec = (
{$ifdef go32v2}
openproc : @OpenGo32Coff;
findproc : @FindSectionCoff;
{$endif}
{$ifdef PE32}
openproc : @OpenPeCoff;
findproc : @FindSectionCoff;
{$endif}
{$ifdef PE32PLUS}
openproc : @OpenPePlusCoff;
findproc : @FindSectionCoff;
{$endif PE32PLUS}
{$if defined(ELF32) or defined(ELF64)}
openproc : @OpenElf;
findproc : @FindSectionElf;
{$endif ELF32 or ELF64}
{$ifdef BEOS}
openproc : @OpenElf32Beos;
findproc : @FindSectionElf;
{$endif BEOS}
{$ifdef darwin}
openproc : @OpenMachO32PPC;
findproc : @FindSectionMachO32PPC;
{$endif darwin}
{$IFDEF EMX}
openproc : @OpenEMXaout;
findproc : @FindSectionEMXaout;
{$ENDIF EMX}
{$ifdef netware}
openproc : @OpenNetwareNLM;
findproc : @FindSectionNetwareNLM;
{$endif}
);
function OpenExeFile(out e:TExeFile;const fn:string):boolean;
var
ofm : word;
begin
result:=false;
fillchar(e,sizeof(e),0);
e.bufsize:=sizeof(e.buf);
e.filename:=fn;
assign(e.f,fn);
{$I-}
ofm:=filemode;
filemode:=$40;
reset(e.f,1);
filemode:=ofm;
{$I+}
if ioresult<>0 then
exit;
e.isopen:=true;
// cache filesize
e.size:=filesize(e.f);
E.FunctionRelative := true;
if ExeProcs.OpenProc<>nil then
result:=ExeProcs.OpenProc(e);
end;
function CloseExeFile(var e:TExeFile):boolean;
begin
result:=false;
if not e.isopen then
exit;
e.isopen:=false;
close(e.f);
result:=true;
end;
function FindExeSection(var e:TExeFile;const secname:string;out secofs,seclen:longint):boolean;
begin
result:=false;
if not e.isopen then
exit;
if ExeProcs.FindProc<>nil then
result:=ExeProcs.FindProc(e,secname,secofs,seclen);
end;
function CheckDbgFile(var e:TExeFile;const fn:string;dbgcrc:cardinal):boolean;
var
c : cardinal;
ofm : word;
g : file;
begin
result:=false;
assign(g,fn);
{$I-}
ofm:=filemode;
filemode:=$40;
reset(g,1);
filemode:=ofm;
{$I+}
if ioresult<>0 then
exit;
{ We reuse the buffer from e here to prevent too much stack allocation }
c:=0;
repeat
blockread(g,e.buf,e.bufsize,e.bufcnt);
c:=UpdateCrc32(c,e.buf,e.bufcnt);
until e.bufcnt<e.bufsize;
close(g);
result:=(dbgcrc=c);
end;
function ReadDebugLink(var e:TExeFile;out dbgfn:string):boolean;
var
dbglink : array[0..255] of char;
i,
dbglinklen,
dbglinkofs : longint;
dbgcrc : cardinal;
begin
result:=false;
if not FindExeSection(e,'.gnu_debuglink',dbglinkofs,dbglinklen) then
exit;
if dbglinklen>sizeof(dbglink)-1 then
exit;
fillchar(dbglink,sizeof(dbglink),0);
seek(e.f,dbglinkofs);
blockread(e.f,dbglink,dbglinklen);
dbgfn:=strpas(dbglink);
if length(dbgfn)=0 then
exit;
i:=align(length(dbgfn)+1,4);
if i>dbglinklen then
exit;
move(dbglink[i],dbgcrc,4);
{ current dir }
if CheckDbgFile(e,dbgfn,dbgcrc) then
begin
result:=true;
exit;
end;
{ executable dir }
i:=length(e.filename);
while (i>0) and not(e.filename[i] in AllowDirectorySeparators) do
dec(i);
if i>0 then
begin
dbgfn:=copy(e.filename,1,i)+dbgfn;
if CheckDbgFile(e,dbgfn,dbgcrc) then
begin
result:=true;
exit;
end;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink