1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 2008 by Peter Vreman
4
5    Executable file reading functions
6
7    See the file COPYING.FPC, included in this distribution,
8    for details about the copyright.
9
10    This program is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************}
15{
16  This unit should not be compiled in objfpc mode, since this would make it
17  dependent on objpas unit.
18}
19
20{ Disable checks of pointers explictly,
21  as we are dealing here with special pointer that
22  might be seen as invalid by heaptrc unit CheckPointer function }
23
24{$checkpointer off}
25
26unit exeinfo;
27interface
28
29{$S-}
30
31type
32  TExeFile=record
33    f : file;
34    // cached filesize
35    size      : int64;
36    isopen    : boolean;
37    nsects    : longint;
38    sechdrofs,
39    secstrofs : {$ifdef cpui8086}longword{$else}ptruint{$endif};
40    processaddress : {$ifdef cpui8086}word{$else}ptruint{$endif};
41{$ifdef cpui8086}
42    processsegment : word;
43{$endif cpui8086}
44    FunctionRelative: boolean;
45    // Offset of the binary image forming permanent offset to all retrieved values
46    ImgOffset: {$ifdef cpui8086}longword{$else}ptruint{$endif};
47    filename  : string;
48    // Allocate static buffer for reading data
49    buf       : array[0..4095] of byte;
50    bufsize,
51    bufcnt    : longint;
52  end;
53
54function OpenExeFile(var e:TExeFile;const fn:string):boolean;
55function FindExeSection(var e:TExeFile;const secname:string;var secofs,seclen:longint):boolean;
56function CloseExeFile(var e:TExeFile):boolean;
57function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
58
59{$ifdef CPUI8086}
60procedure GetModuleByAddr(addr: farpointer; var baseaddr: farpointer; var filename: string);
61{$else CPUI8086}
62procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
63{$endif CPUI8086}
64
65implementation
66
67uses
68  strings{$ifdef windows},windows{$endif windows};
69
70{$if defined(unix) and not defined(beos) and not defined(haiku)}
71
72  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
73    begin
74      if assigned(UnixGetModuleByAddrHook) then
75        UnixGetModuleByAddrHook(addr,baseaddr,filename)
76      else
77        begin
78          baseaddr:=nil;
79          filename:=ParamStr(0);
80        end;
81    end;
82
83{$elseif defined(windows)}
84
85  var
86    Tmm: TMemoryBasicInformation;
87{$ifdef FPC_OS_UNICODE}
88    TST: array[0..Max_Path] of WideChar;
89{$else}
90    TST: array[0..Max_Path] of Char;
91{$endif FPC_OS_UNICODE}
92  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
93    begin
94      baseaddr:=nil;
95      if VirtualQuery(addr, @Tmm, SizeOf(Tmm))<>sizeof(Tmm) then
96        filename:=ParamStr(0)
97      else
98        begin
99          baseaddr:=Tmm.AllocationBase;
100          TST[0]:= #0;
101          if baseaddr <> nil then
102            begin
103              GetModuleFileName(THandle(Tmm.AllocationBase), TST, Length(TST));
104{$ifdef FPC_OS_UNICODE}
105              filename:= String(PWideChar(@TST));
106{$else}
107              filename:= String(PChar(@TST));
108{$endif FPC_OS_UNICODE}
109            end;
110        end;
111    end;
112
113{$elseif defined(morphos)}
114
115  procedure startsymbol; external name '_start';
116
117  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
118    begin
119      baseaddr:= @startsymbol;
120{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
121      filename:=ParamStr(0);
122{$else FPC_HAS_FEATURE_COMMANDARGS}
123      filename:='';
124{$endif FPC_HAS_FEATURE_COMMANDARGS}
125    end;
126
127{$elseif defined(msdos)}
128
129  procedure GetModuleByAddr(addr: farpointer; var baseaddr: farpointer; var filename: string);
130    begin
131      baseaddr:=Ptr(PrefixSeg+16,0);
132      filename:=ParamStr(0);
133    end;
134
135{$elseif defined(beos) or defined(haiku)}
136
137{$i ptypes.inc}
138{$i ostypes.inc}
139
140  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';
141
142  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
143    const
144      B_OK = 0;
145    var
146      cookie    : longint;
147      info      : image_info;
148    begin
149      filename:='';
150      baseaddr:=nil;
151
152      cookie:=0;
153      fillchar(info, sizeof(image_info), 0);
154
155      while get_next_image_info(0,cookie,info,sizeof(info))=B_OK do
156        begin
157          if (info._type = B_APP_IMAGE) and
158             (addr >= info.text) and (addr <= (info.text + info.text_size)) then
159            begin
160              baseaddr:=info.text;
161              filename:=PChar(@info.name);
162            end;
163        end;
164    end;
165
166{$else}
167
168{$ifdef CPUI8086}
169  procedure GetModuleByAddr(addr: farpointer; var baseaddr: farpointer; var filename: string);
170{$else CPUI8086}
171  procedure GetModuleByAddr(addr: pointer; var baseaddr: pointer; var filename: string);
172{$endif CPUI8086}
173    begin
174      baseaddr:= nil;
175{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
176      filename:=ParamStr(0);
177{$else FPC_HAS_FEATURE_COMMANDARGS}
178      filename:='';
179{$endif FPC_HAS_FEATURE_COMMANDARGS}
180    end;
181
182{$endif}
183
184{****************************************************************************
185                             Executable Loaders
186****************************************************************************}
187
188{$if defined(freebsd) or defined(netbsd) or defined (openbsd) or defined(linux) or defined(sunos) or defined(android) or defined(dragonfly)}
189  {$ifdef cpu64}
190    {$define ELF64}
191    {$define FIND_BASEADDR_ELF}
192  {$else}
193    {$define ELF32}
194    {$define FIND_BASEADDR_ELF}
195  {$endif}
196{$endif}
197
198{$if defined(beos) or defined(haiku)}
199  {$ifdef cpu64}
200    {$define ELF64}
201  {$else}
202    {$define ELF32}
203  {$endif}
204{$endif}
205
206{$if defined(morphos)}
207  {$define ELF32}
208{$endif}
209
210{$if defined(msdos)}
211  {$define ELF32}
212{$endif}
213
214{$if defined(win32) or defined(wince)}
215  {$define PE32}
216{$endif}
217
218{$if defined(win64)}
219  {$define PE32PLUS}
220{$endif}
221
222{$ifdef netwlibc}
223  {$define netware}
224{$endif}
225
226{$IFDEF OS2}
227  {$DEFINE EMX}
228{$ENDIF OS2}
229
230
231{****************************************************************************
232                              DOS Stub
233****************************************************************************}
234
235{$if defined(EMX) or defined(PE32) or defined(PE32PLUS) or defined(GO32V2) or defined(MSDOS)}
236type
237  tdosheader = packed record
238     e_magic : word;
239     e_cblp : word;
240     e_cp : word;
241     e_crlc : word;
242     e_cparhdr : word;
243     e_minalloc : word;
244     e_maxalloc : word;
245     e_ss : word;
246     e_sp : word;
247     e_csum : word;
248     e_ip : word;
249     e_cs : word;
250     e_lfarlc : word;
251     e_ovno : word;
252     e_res : array[0..3] of word;
253     e_oemid : word;
254     e_oeminfo : word;
255     e_res2 : array[0..9] of word;
256     e_lfanew : longint;
257  end;
258{$endif EMX or PE32 or PE32PLUS or GO32v2}
259
260
261{****************************************************************************
262                                  NLM
263****************************************************************************}
264
265{$ifdef netware}
266
267function getByte(var f:file):byte;
268  begin
269    BlockRead (f,getByte,1);
270  end;
271
272  procedure Skip (var f:file; bytes : longint);
273  var i : longint;
274  begin
275    for i := 1 to bytes do getbyte(f);
276  end;
277
278  function get0String (var f:file) : string;
279  var c : char;
280  begin
281    get0String := '';
282    c := char (getbyte(f));
283    while (c <> #0) do
284    begin
285      get0String := get0String + c;
286      c := char (getbyte(f));
287    end;
288  end;
289
290  function getint32 (var f:file): longint;
291  begin
292    blockread (F, getint32, 4);
293  end;
294
295
296const SIZE_OF_NLM_INTERNAL_FIXED_HEADER = 130;
297      SIZE_OF_NLM_INTERNAL_VERSION_HEADER = 32;
298      SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER = 124;
299
300function openNetwareNLM(var e:TExeFile):boolean;
301var valid : boolean;
302    name  : string;
303    hdrLength,
304    dataOffset,
305    dataLength : longint;
306
307
308  function getLString : String;
309  var Res:string;
310  begin
311    blockread (e.F, res, 1);
312    if length (res) > 0 THEN
313      blockread (e.F, res[1], length (res));
314    getbyte(e.f);
315    getLString := res;
316  end;
317
318  function getFixString (Len : byte) : string;
319  var i : byte;
320  begin
321    getFixString := '';
322    for I := 1 to Len do
323      getFixString := getFixString + char (getbyte(e.f));
324  end;
325
326
327  function getword : word;
328  begin
329    blockread (e.F, getword, 2);
330  end;
331
332
333
334begin
335  e.sechdrofs := 0;
336  openNetwareNLM:=false;
337
338  // read and check header
339  Skip (e.f,SIZE_OF_NLM_INTERNAL_FIXED_HEADER);
340  getLString;  // NLM Description
341  getInt32(e.f);    // Stacksize
342  getInt32(e.f);    // Reserved
343  skip(e.f,5);     // old Thread Name
344  getLString;  // Screen Name
345  getLString;  // Thread Name
346  hdrLength := -1;
347  dataOffset := -1;
348  dataLength := -1;
349  valid := true;
350  repeat
351    name := getFixString (8);
352    if (name = 'VeRsIoN#') then
353    begin
354      Skip (e.f,SIZE_OF_NLM_INTERNAL_VERSION_HEADER-8);
355    end else
356    if (name = 'CoPyRiGh') then
357    begin
358      getword;     // T=
359      getLString;  // Copyright String
360    end else
361    if (name = 'MeSsAgEs') then
362    begin
363      skip (e.f,SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER - 8);
364    end else
365    if (name = 'CuStHeAd') then
366    begin
367      hdrLength := getInt32(e.f);
368      dataOffset := getInt32(e.f);
369      dataLength := getInt32(e.f);
370      Skip (e.f,8); // dateStamp
371      Valid := false;
372    end else
373      Valid := false;
374  until not valid;
375  if (hdrLength = -1) or (dataOffset = -1) or (dataLength = -1) then
376    exit;
377
378  Seek (e.F, dataOffset);
379  e.sechdrofs := dataOffset;
380  openNetwareNLM := (e.sechdrofs > 0);
381end;
382
383function FindSectionNetwareNLM(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
384var name : string;
385    alignAmount : longint;
386begin
387  seek(e.f,e.sechdrofs);
388    (* The format of the section information is:
389       null terminated section name
390       zeroes to adjust to 4 byte boundary
391       4 byte section data file pointer
392       4 byte section size *)
393  Repeat
394    Name := Get0String(e.f);
395    alignAmount := 4 - ((length (Name) + 1) MOD 4);
396    Skip (e.f,AlignAmount);
397    if (Name = asecname) then
398    begin
399      secOfs := getInt32(e.f);
400      secLen := getInt32(e.f);
401    end else
402      Skip(e.f,8);
403  until (Name = '') or (Name = asecname);
404  FindSectionNetwareNLM := (Name=asecname);
405end;
406
407{$endif}
408
409
410{****************************************************************************
411                               COFF
412****************************************************************************}
413
414{$if defined(PE32) or defined(PE32PLUS) or defined(GO32V2)}
415type
416  tcoffsechdr=packed record
417    name     : array[0..7] of char;
418    vsize    : longint;
419    rvaofs   : longint;
420    datalen  : longint;
421    datapos  : longint;
422    relocpos : longint;
423    lineno1  : longint;
424    nrelocs  : word;
425    lineno2  : word;
426    flags    : longint;
427  end;
428  coffsymbol=packed record
429    name    : array[0..3] of char; { real is [0..7], which overlaps the strofs ! }
430    strofs  : longint;
431    value   : longint;
432    section : smallint;
433    empty   : word;
434    typ     : byte;
435    aux     : byte;
436  end;
437
438function FindSectionCoff(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
439var
440  i : longint;
441  sechdr     : tcoffsechdr;
442  secname    : string;
443  secnamebuf : array[0..255] of char;
444  code,
445  oldofs,
446  bufsize    : longint;
447  strofs     : cardinal;
448begin
449  FindSectionCoff:=false;
450  { read section info }
451  seek(e.f,e.sechdrofs);
452  for i:=1 to e.nsects do
453   begin
454     blockread(e.f,sechdr,sizeof(sechdr),bufsize);
455     move(sechdr.name,secnamebuf,8);
456     secnamebuf[8]:=#0;
457     secname:=strpas(secnamebuf);
458     if secname[1]='/' then
459       begin
460         Val(Copy(secname,2,8),strofs,code);
461         if code=0 then
462           begin
463             fillchar(secnamebuf,sizeof(secnamebuf),0);
464             oldofs:=filepos(e.f);
465             seek(e.f,e.secstrofs+strofs);
466             blockread(e.f,secnamebuf,sizeof(secnamebuf),bufsize);
467             seek(e.f,oldofs);
468             secname:=strpas(secnamebuf);
469           end
470         else
471           secname:='';
472       end;
473     if asecname=secname then
474       begin
475         secofs:=cardinal(sechdr.datapos) + E.ImgOffset;
476{$ifdef GO32V2}
477         seclen:=sechdr.datalen;
478{$else GO32V2}
479         { In PECOFF, datalen includes file padding up to the next section.
480           vsize is the actual payload size if it does not exceed datalen,
481           otherwise it is .bss (or alike) section that we should ignore.  }
482         if sechdr.vsize<=sechdr.datalen then
483           seclen:=sechdr.vsize
484         else
485           exit;
486{$endif GO32V2}
487         FindSectionCoff:=true;
488         exit;
489       end;
490   end;
491end;
492{$endif PE32 or PE32PLUS or GO32V2}
493
494
495{$ifdef go32v2}
496function OpenGo32Coff(var e:TExeFile):boolean;
497type
498  tgo32coffheader=packed record
499    mach   : word;
500    nsects : word;
501    time   : longint;
502    sympos : longint;
503    syms   : longint;
504    opthdr : word;
505    flag   : word;
506    other  : array[0..27] of byte;
507  end;
508const
509  ParagraphSize = 512;
510var
511  coffheader : tgo32coffheader;
512  DosHeader: TDosHeader;
513  BRead: cardinal;
514begin
515  OpenGo32Coff:=false;
516  { read and check header }
517  if E.Size < SizeOf (DosHeader) then
518   Exit;
519  BlockRead (E.F, DosHeader, SizeOf (DosHeader), BRead);
520  if BRead <> SizeOf (DosHeader) then
521   Exit;
522  if DosHeader.E_Magic = $5A4D then
523  begin
524   E.ImgOffset := DosHeader.e_cp * ParagraphSize;
525   if DosHeader.e_cblp > 0 then
526    E.ImgOffset := E.ImgOffset + DosHeader.e_cblp - ParagraphSize;
527  end;
528  if e.size < E.ImgOffset + sizeof(coffheader) then
529   exit;
530  seek(e.f,E.ImgOffset);
531  blockread(e.f,coffheader,sizeof(coffheader));
532  if coffheader.mach<>$14c then
533    exit;
534  e.sechdrofs:=filepos(e.f);
535  e.nsects:=coffheader.nsects;
536  e.secstrofs:=coffheader.sympos+coffheader.syms*sizeof(coffsymbol)+4;
537  if e.secstrofs>e.size then
538    exit;
539  OpenGo32Coff:=true;
540end;
541{$endif Go32v2}
542
543
544{$ifdef PE32}
545function OpenPeCoff(var e:TExeFile):boolean;
546type
547  tpeheader = packed record
548     PEMagic : longint;
549     Machine : word;
550     NumberOfSections : word;
551     TimeDateStamp : longint;
552     PointerToSymbolTable : longint;
553     NumberOfSymbols : longint;
554     SizeOfOptionalHeader : word;
555     Characteristics : word;
556     Magic : word;
557     MajorLinkerVersion : byte;
558     MinorLinkerVersion : byte;
559     SizeOfCode : longint;
560     SizeOfInitializedData : longint;
561     SizeOfUninitializedData : longint;
562     AddressOfEntryPoint : longint;
563     BaseOfCode : longint;
564     BaseOfData : longint;
565     ImageBase : longint;
566     SectionAlignment : longint;
567     FileAlignment : longint;
568     MajorOperatingSystemVersion : word;
569     MinorOperatingSystemVersion : word;
570     MajorImageVersion : word;
571     MinorImageVersion : word;
572     MajorSubsystemVersion : word;
573     MinorSubsystemVersion : word;
574     Reserved1 : longint;
575     SizeOfImage : longint;
576     SizeOfHeaders : longint;
577     CheckSum : longint;
578     Subsystem : word;
579     DllCharacteristics : word;
580     SizeOfStackReserve : longint;
581     SizeOfStackCommit : longint;
582     SizeOfHeapReserve : longint;
583     SizeOfHeapCommit : longint;
584     LoaderFlags : longint;
585     NumberOfRvaAndSizes : longint;
586     DataDirectory : array[1..$80] of byte;
587  end;
588var
589  dosheader  : tdosheader;
590  peheader   : tpeheader;
591begin
592  OpenPeCoff:=false;
593  { read and check header }
594  if e.size<sizeof(dosheader) then
595    exit;
596  blockread(e.f,dosheader,sizeof(tdosheader));
597  seek(e.f,dosheader.e_lfanew);
598  blockread(e.f,peheader,sizeof(tpeheader));
599  if peheader.pemagic<>$4550 then
600    exit;
601  e.sechdrofs:=filepos(e.f);
602  e.nsects:=peheader.NumberOfSections;
603  e.secstrofs:=peheader.PointerToSymbolTable+peheader.NumberOfSymbols*sizeof(coffsymbol);
604  if e.secstrofs>e.size then
605    exit;
606  e.processaddress:=peheader.ImageBase;
607  OpenPeCoff:=true;
608end;
609{$endif PE32}
610
611
612{$ifdef PE32PLUS}
613function OpenPePlusCoff(var e:TExeFile):boolean;
614type
615  tpeheader = packed record
616     PEMagic : longint;
617     Machine : word;
618     NumberOfSections : word;
619     TimeDateStamp : longint;
620     PointerToSymbolTable : longint;
621     NumberOfSymbols : longint;
622     SizeOfOptionalHeader : word;
623     Characteristics : word;
624     Magic : word;
625     MajorLinkerVersion : byte;
626     MinorLinkerVersion : byte;
627     SizeOfCode : longint;
628     SizeOfInitializedData : longint;
629     SizeOfUninitializedData : longint;
630     AddressOfEntryPoint : longint;
631     BaseOfCode : longint;
632     ImageBase : qword;
633     SectionAlignment : longint;
634     FileAlignment : longint;
635     MajorOperatingSystemVersion : word;
636     MinorOperatingSystemVersion : word;
637     MajorImageVersion : word;
638     MinorImageVersion : word;
639     MajorSubsystemVersion : word;
640     MinorSubsystemVersion : word;
641     Reserved1 : longint;
642     SizeOfImage : longint;
643     SizeOfHeaders : longint;
644     CheckSum : longint;
645     Subsystem : word;
646     DllCharacteristics : word;
647     SizeOfStackReserve : qword;
648     SizeOfStackCommit : qword;
649     SizeOfHeapReserve : qword;
650     SizeOfHeapCommit : qword;
651     LoaderFlags : longint;
652     NumberOfRvaAndSizes : longint;
653     DataDirectory : array[1..$80] of byte;
654  end;
655var
656  dosheader  : tdosheader;
657  peheader   : tpeheader;
658begin
659  OpenPePlusCoff:=false;
660  { read and check header }
661  if E.Size<sizeof(dosheader) then
662   exit;
663  blockread(E.F,dosheader,sizeof(tdosheader));
664  seek(E.F,dosheader.e_lfanew);
665  blockread(E.F,peheader,sizeof(tpeheader));
666  if peheader.pemagic<>$4550 then
667   exit;
668  e.sechdrofs:=filepos(e.f);
669  e.nsects:=peheader.NumberOfSections;
670  e.secstrofs:=peheader.PointerToSymbolTable+peheader.NumberOfSymbols*sizeof(coffsymbol);
671  if e.secstrofs>e.size then
672    exit;
673  e.processaddress:=peheader.ImageBase;
674  OpenPePlusCoff:=true;
675end;
676{$endif PE32PLUS}
677
678
679{****************************************************************************
680                                 AOUT
681****************************************************************************}
682
683{$IFDEF EMX}
684type
685  TEmxHeader = packed record
686     Version: array [1..16] of char;
687     Bound: word;
688     AoutOfs: longint;
689     Options: array [1..42] of char;
690  end;
691
692  TAoutHeader = packed record
693     Magic: word;
694     Machine: byte;
695     Flags: byte;
696     TextSize: longint;
697     DataSize: longint;
698     BssSize: longint;
699     SymbSize: longint;
700     EntryPoint: longint;
701     TextRelocSize: longint;
702     DataRelocSize: longint;
703  end;
704
705const
706 PageSizeFill = $FFF;
707
708var
709 DosHeader: TDosHeader;
710 EmxHeader: TEmxHeader;
711 AoutHeader: TAoutHeader;
712 StabOfs: PtrUInt;
713 S4: string [4];
714
715function OpenEMXaout (var E: TExeFile): boolean;
716begin
717 OpenEMXaout := false;
718{ GDB after 4.18 uses offset to function begin
719  in text section but OS/2 version still uses 4.16 PM }
720 E.FunctionRelative := false;
721{ read and check header }
722 if E.Size > SizeOf (DosHeader) then
723 begin
724  BlockRead (E.F, DosHeader, SizeOf (TDosHeader));
725{$IFDEF DEBUG_LINEINFO}
726  WriteLn (StdErr, 'DosHeader.E_CParHdr = ', DosHeader.E_cParHdr);
727{$ENDIF DEBUG_LINEINFO}
728  if E.Size > DosHeader.e_cparhdr shl 4 + SizeOf (TEmxHeader) then
729  begin
730   Seek (E.F, DosHeader.e_cparhdr shl 4);
731   BlockRead (E.F, EmxHeader, SizeOf (TEmxHeader));
732  S4 [0] := #4;
733  Move (EmxHeader.Version, S4 [1], 4);
734   if (S4 = 'emx ') and
735                       (E.Size > EmxHeader.AoutOfs + SizeOf (TAoutHeader)) then
736   begin
737{$IFDEF DEBUG_LINEINFO}
738    WriteLn (StdErr, 'EmxHeader.AoutOfs = ', EmxHeader.AoutOfs, '/', HexStr (pointer (EmxHeader.AoutOfs)));
739{$ENDIF DEBUG_LINEINFO}
740    Seek (E.F, EmxHeader.AoutOfs);
741    BlockRead (E.F, AoutHeader, SizeOf (TAoutHeader));
742{$IFDEF DEBUG_LINEINFO}
743    WriteLn (StdErr, 'AoutHeader.Magic = ', AoutHeader.Magic);
744{$ENDIF DEBUG_LINEINFO}
745{    if AOutHeader.Magic = $10B then}
746    StabOfs := (EmxHeader.AoutOfs or PageSizeFill) + 1
747                 + AoutHeader.TextSize
748                 + AoutHeader.DataSize
749                 + AoutHeader.TextRelocSize
750                 + AoutHeader.DataRelocSize;
751{$IFDEF DEBUG_LINEINFO}
752    WriteLn (StdErr, 'AoutHeader.TextSize = ', AoutHeader.TextSize, '/', HexStr (pointer (AoutHeader.TextSize)));
753    WriteLn (StdErr, 'AoutHeader.DataSize = ', AoutHeader.DataSize, '/', HexStr (pointer (AoutHeader.DataSize)));
754    WriteLn (StdErr, 'AoutHeader.TextRelocSize = ', AoutHeader.TextRelocSize, '/', HexStr (pointer (AoutHeader.TextRelocSize)));
755    WriteLn (StdErr, 'AoutHeader.DataRelocSize = ', AoutHeader.DataRelocSize, '/', HexStr (pointer (AoutHeader.DataRelocSize)));
756    WriteLn (StdErr, 'AoutHeader.SymbSize = ', AoutHeader.SymbSize, '/', HexStr (pointer (AoutHeader.SymbSize)));
757    WriteLn (StdErr, 'StabOfs = ', StabOfs, '/', HexStr (pointer (StabOfs)));
758{$ENDIF DEBUG_LINEINFO}
759    if E.Size > StabOfs + AoutHeader.SymbSize then
760     OpenEMXaout := true;
761   end;
762  end;
763 end;
764end;
765
766
767function FindSectionEMXaout (var E: TExeFile; const ASecName: string;
768                                         var SecOfs, SecLen: longint): boolean;
769begin
770 FindSectionEMXaout := false;
771 if ASecName = '.stab' then
772 begin
773  SecOfs := StabOfs;
774  SecLen := AoutHeader.SymbSize;
775  FindSectionEMXaout := true;
776 end else
777 if ASecName = '.stabstr' then
778 begin
779  SecOfs := StabOfs + AoutHeader.SymbSize;
780  SecLen := E.Size - Pred (SecOfs);
781  FindSectionEMXaout := true;
782 end;
783end;
784{$ENDIF EMX}
785
786
787{****************************************************************************
788                                 ELF
789****************************************************************************}
790
791{$if defined(ELF32)}
792type
793  telfheader=packed record
794      magic0123         : longint;
795      file_class        : byte;
796      data_encoding     : byte;
797      file_version      : byte;
798      padding           : array[$07..$0f] of byte;
799      e_type            : word;
800      e_machine         : word;
801      e_version         : longword;
802      e_entry           : longword;                  // entrypoint
803      e_phoff           : longword;                  // program header offset
804      e_shoff           : longword;                  // sections header offset
805      e_flags           : longword;
806      e_ehsize          : word;             // elf header size in bytes
807      e_phentsize       : word;             // size of an entry in the program header array
808      e_phnum           : word;             // 0..e_phnum-1 of entrys
809      e_shentsize       : word;             // size of an entry in sections header array
810      e_shnum           : word;             // 0..e_shnum-1 of entrys
811      e_shstrndx        : word;             // index of string section header
812  end;
813  telfsechdr=packed record
814      sh_name           : longword;
815      sh_type           : longword;
816      sh_flags          : longword;
817      sh_addr           : longword;
818      sh_offset         : longword;
819      sh_size           : longword;
820      sh_link           : longword;
821      sh_info           : longword;
822      sh_addralign      : longword;
823      sh_entsize        : longword;
824    end;
825  telfproghdr=packed record
826    p_type            : longword;
827    p_offset          : longword;
828    p_vaddr           : longword;
829    p_paddr           : longword;
830    p_filesz          : longword;
831    p_memsz           : longword;
832    p_flags           : longword;
833    p_align           : longword;
834  end;
835{$endif ELF32}
836{$ifdef ELF64}
837type
838  telfheader=packed record
839      magic0123         : longint;
840      file_class        : byte;
841      data_encoding     : byte;
842      file_version      : byte;
843      padding           : array[$07..$0f] of byte;
844      e_type            : word;
845      e_machine         : word;
846      e_version         : longword;
847      e_entry           : int64;                  // entrypoint
848      e_phoff           : int64;                  // program header offset
849      e_shoff           : int64;                  // sections header offset
850      e_flags           : longword;
851      e_ehsize          : word;             // elf header size in bytes
852      e_phentsize       : word;             // size of an entry in the program header array
853      e_phnum           : word;             // 0..e_phnum-1 of entrys
854      e_shentsize       : word;             // size of an entry in sections header array
855      e_shnum           : word;             // 0..e_shnum-1 of entrys
856      e_shstrndx        : word;             // index of string section header
857  end;
858type
859  telfsechdr=packed record
860      sh_name           : longword;
861      sh_type           : longword;
862      sh_flags          : int64;
863      sh_addr           : int64;
864      sh_offset         : int64;
865      sh_size           : int64;
866      sh_link           : longword;
867      sh_info           : longword;
868      sh_addralign      : int64;
869      sh_entsize        : int64;
870    end;
871
872  telfproghdr=packed record
873    p_type            : longword;
874    p_flags           : longword;
875    p_offset          : qword;
876    p_vaddr           : qword;
877    p_paddr           : qword;
878    p_filesz          : qword;
879    p_memsz           : qword;
880    p_align           : qword;
881  end;
882{$endif ELF64}
883
884
885{$if defined(ELF32) or defined(ELF64)}
886
887{$ifdef FIND_BASEADDR_ELF}
888var
889  LocalJmpBuf : Jmp_Buf;
890procedure LocalError;
891begin
892  Longjmp(LocalJmpBuf,1);
893end;
894
895procedure GetExeInMemoryBaseAddr(addr : pointer; var BaseAddr : pointer;
896                                 var filename : openstring);
897type
898  AT_HDR = record
899    typ : ptruint;
900    value : ptruint;
901  end;
902  P_AT_HDR = ^AT_HDR;
903
904{ Values taken from /usr/include/linux/auxvec.h }
905const
906  AT_HDR_COUNT = 5;{ AT_PHNUM }
907  AT_HDR_SIZE = 4; { AT_PHENT }
908  AT_HDR_Addr = 3; { AT_PHDR }
909  AT_EXE_FN = 31;  {AT_EXECFN }
910
911var
912  pc : ppchar;
913  pat_hdr : P_AT_HDR;
914  i, phdr_count : ptrint;
915  phdr_size : ptruint;
916  phdr :  ^telfproghdr;
917  found_addr : ptruint;
918  SavedExitProc : pointer;
919begin
920  filename:=ParamStr(0);
921  SavedExitProc:=ExitProc;
922  ExitProc:=@LocalError;
923  if SetJmp(LocalJmpBuf)=0 then
924  begin
925  { Try, avoided in order to remove exception installation }
926    pc:=envp;
927    phdr_count:=-1;
928    phdr_size:=0;
929    phdr:=nil;
930    found_addr:=ptruint(-1);
931    while (assigned(pc^)) do
932      inc (pointer(pc), sizeof(ptruint));
933    inc(pointer(pc), sizeof(ptruint));
934    pat_hdr:=P_AT_HDR(pc);
935    while assigned(pat_hdr) do
936      begin
937        if (pat_hdr^.typ=0) and (pat_hdr^.value=0) then
938          break;
939        if pat_hdr^.typ = AT_HDR_COUNT then
940          phdr_count:=pat_hdr^.value;
941        if pat_hdr^.typ = AT_HDR_SIZE then
942          phdr_size:=pat_hdr^.value;
943        if pat_hdr^.typ = AT_HDR_Addr then
944          phdr := pointer(pat_hdr^.value);
945        if pat_hdr^.typ = AT_EXE_FN then
946          filename:=strpas(pchar(pat_hdr^.value));
947        inc (pointer(pat_hdr),sizeof(AT_HDR));
948      end;
949    if (phdr_count>0) and (phdr_size = sizeof (telfproghdr))
950       and  assigned(phdr) then
951      begin
952        for i:=0 to phdr_count -1 do
953          begin
954            if (phdr^.p_type = 1 {PT_LOAD}) and (ptruint(phdr^.p_vaddr) < found_addr) then
955              found_addr:=phdr^.p_vaddr;
956            inc(pointer(phdr), phdr_size);
957          end;
958      {$ifdef DEBUG_LINEINFO}
959      end
960    else
961      begin
962        if (phdr_count=-1) then
963           writeln(stderr,'AUX entry AT_PHNUM not found');
964        if (phdr_size=0) then
965           writeln(stderr,'AUX entry AT_PHENT not found');
966        if (phdr=nil) then
967           writeln(stderr,'AUX entry AT_PHDR not found');
968      {$endif DEBUG_LINEINFO}
969      end;
970
971     if found_addr<>ptruint(-1) then
972       begin
973          {$ifdef DEBUG_LINEINFO}
974          Writeln(stderr,'Found addr = $',hexstr(found_addr,2 * sizeof(ptruint)));
975          {$endif}
976          BaseAddr:=pointer(found_addr);
977       end
978  {$ifdef DEBUG_LINEINFO}
979     else
980    writeln(stderr,'Error parsing stack');
981  {$endif DEBUG_LINEINFO}
982  end
983  else
984  begin
985  {$ifdef DEBUG_LINEINFO}
986    writeln(stderr,'Exception parsing stack');
987  {$endif DEBUG_LINEINFO}
988  end;
989  ExitProc:=SavedExitProc;
990end;
991{$endif FIND_BASEADDR_ELF}
992
993function OpenElf(var e:TExeFile):boolean;
994{$ifdef MSDOS}
995const
996  ParagraphSize = 512;
997{$endif MSDOS}
998var
999  elfheader : telfheader;
1000  elfsec    : telfsechdr;
1001  phdr      : telfproghdr;
1002  i         : longint;
1003{$ifdef MSDOS}
1004  DosHeader : tdosheader;
1005  BRead     : cardinal;
1006{$endif MSDOS}
1007begin
1008  OpenElf:=false;
1009{$ifdef MSDOS}
1010  { read and check header }
1011  if E.Size < SizeOf (DosHeader) then
1012   Exit;
1013  BlockRead (E.F, DosHeader, SizeOf (DosHeader), BRead);
1014  if BRead <> SizeOf (DosHeader) then
1015   Exit;
1016  if DosHeader.E_Magic = $5A4D then
1017  begin
1018   E.ImgOffset := LongWord(DosHeader.e_cp) * ParagraphSize;
1019   if DosHeader.e_cblp > 0 then
1020    E.ImgOffset := E.ImgOffset + DosHeader.e_cblp - ParagraphSize;
1021  end;
1022{$endif MSDOS}
1023  { read and check header }
1024  if e.size<(sizeof(telfheader)+e.ImgOffset) then
1025   exit;
1026  seek(e.f,e.ImgOffset);
1027  blockread(e.f,elfheader,sizeof(telfheader));
1028 if elfheader.magic0123<>{$ifdef ENDIAN_LITTLE}$464c457f{$else}$7f454c46{$endif} then
1029   exit;
1030  if elfheader.e_shentsize<>sizeof(telfsechdr) then
1031   exit;
1032  { read section names }
1033  seek(e.f,e.ImgOffset+elfheader.e_shoff+elfheader.e_shstrndx*cardinal(sizeof(telfsechdr)));
1034  blockread(e.f,elfsec,sizeof(telfsechdr));
1035  e.secstrofs:=elfsec.sh_offset;
1036  e.sechdrofs:=elfheader.e_shoff;
1037  e.nsects:=elfheader.e_shnum;
1038
1039{$ifdef MSDOS}
1040  { e.processaddress is already initialized to 0 }
1041  e.processsegment:=PrefixSeg+16;
1042{$else MSDOS}
1043  { scan program headers to find the image base address }
1044  e.processaddress:=High(e.processaddress);
1045  seek(e.f,e.ImgOffset+elfheader.e_phoff);
1046  for i:=1 to elfheader.e_phnum do
1047    begin
1048      blockread(e.f,phdr,sizeof(phdr));
1049      if (phdr.p_type = 1 {PT_LOAD}) and (ptruint(phdr.p_vaddr) < e.processaddress) then
1050        e.processaddress:=phdr.p_vaddr;
1051    end;
1052
1053  if e.processaddress = High(e.processaddress) then
1054    e.processaddress:=0;
1055{$endif MSDOS}
1056
1057  OpenElf:=true;
1058end;
1059
1060
1061function FindSectionElf(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
1062var
1063  elfsec     : telfsechdr;
1064  secname    : string;
1065  secnamebuf : array[0..255] of char;
1066  oldofs,
1067  bufsize,i  : longint;
1068begin
1069  FindSectionElf:=false;
1070  seek(e.f,e.ImgOffset+e.sechdrofs);
1071  for i:=1 to e.nsects do
1072   begin
1073     blockread(e.f,elfsec,sizeof(telfsechdr));
1074     fillchar(secnamebuf,sizeof(secnamebuf),0);
1075     oldofs:=filepos(e.f);
1076     seek(e.f,e.ImgOffset+e.secstrofs+elfsec.sh_name);
1077     blockread(e.f,secnamebuf,sizeof(secnamebuf)-1,bufsize);
1078     seek(e.f,oldofs);
1079     secname:=strpas(secnamebuf);
1080     if asecname=secname then
1081       begin
1082         secofs:=e.ImgOffset+elfsec.sh_offset;
1083         seclen:=elfsec.sh_size;
1084         FindSectionElf:=true;
1085         exit;
1086       end;
1087   end;
1088end;
1089{$endif ELF32 or ELF64}
1090
1091
1092{****************************************************************************
1093                                 MACHO
1094****************************************************************************}
1095
1096{$ifdef darwin}
1097type
1098  MachoFatHeader= packed record
1099    magic: longint;
1100    nfatarch: longint;
1101  end;
1102  MachoHeader=packed record
1103    magic: longword;
1104    cpu_type_t: longint;
1105    cpu_subtype_t: longint;
1106    filetype: longint;
1107    ncmds: longint;
1108    sizeofcmds: longint;
1109    flags: longint;
1110  end;
1111  cmdblock=packed record
1112    cmd: longint;
1113    cmdsize: longint;
1114  end;
1115  symbSeg=packed record
1116    symoff :      longint;
1117    nsyms  :      longint;
1118    stroff :      longint;
1119    strsize:      longint;
1120  end;
1121  tstab=packed record
1122    strpos  : longint;
1123    ntype   : byte;
1124    nother  : byte;
1125    ndesc   : word;
1126    nvalue  : dword;
1127  end;
1128
1129
1130function OpenMachO32PPC(var e:TExeFile):boolean;
1131var
1132   mh:MachoHeader;
1133begin
1134  OpenMachO32PPC:= false;
1135  E.FunctionRelative:=false;
1136  if e.size<sizeof(mh) then
1137    exit;
1138  blockread (e.f, mh, sizeof(mh));
1139  e.sechdrofs:=filepos(e.f);
1140  e.nsects:=mh.ncmds;
1141  OpenMachO32PPC:=true;
1142end;
1143
1144
1145function FindSectionMachO32PPC(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
1146var
1147   i: longint;
1148   block:cmdblock;
1149   symbolsSeg: symbSeg;
1150begin
1151  FindSectionMachO32PPC:=false;
1152  seek(e.f,e.sechdrofs);
1153  for i:= 1 to e.nsects do
1154    begin
1155      {$I-}
1156      blockread (e.f, block, sizeof(block));
1157      {$I+}
1158      if IOResult <> 0 then
1159        Exit;
1160      if block.cmd = $2   then
1161      begin
1162          blockread (e.f, symbolsSeg, sizeof(symbolsSeg));
1163          if asecname='.stab' then
1164            begin
1165              secofs:=symbolsSeg.symoff;
1166              { the caller will divide again by sizeof(tstab) }
1167              seclen:=symbolsSeg.nsyms*sizeof(tstab);
1168              FindSectionMachO32PPC:=true;
1169            end
1170          else if asecname='.stabstr' then
1171            begin
1172              secofs:=symbolsSeg.stroff;
1173              seclen:=symbolsSeg.strsize;
1174              FindSectionMachO32PPC:=true;
1175            end;
1176          exit;
1177      end;
1178      Seek(e.f, FilePos (e.f) + block.cmdsize - sizeof(block));
1179    end;
1180end;
1181{$endif darwin}
1182
1183
1184{****************************************************************************
1185                                   CRC
1186****************************************************************************}
1187
1188var
1189  Crc32Tbl : array[0..255] of cardinal;
1190
1191procedure MakeCRC32Tbl;
1192var
1193  crc : cardinal;
1194  i,n : integer;
1195begin
1196  for i:=0 to 255 do
1197   begin
1198     crc:=i;
1199     for n:=1 to 8 do
1200      if (crc and 1)<>0 then
1201       crc:=(crc shr 1) xor cardinal($edb88320)
1202      else
1203       crc:=crc shr 1;
1204     Crc32Tbl[i]:=crc;
1205   end;
1206end;
1207
1208
1209Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:LongInt):cardinal;
1210var
1211  i : LongInt;
1212  p : pchar;
1213begin
1214  if Crc32Tbl[1]=0 then
1215   MakeCrc32Tbl;
1216  p:=@InBuf;
1217  UpdateCrc32:=not InitCrc;
1218  for i:=1 to InLen do
1219   begin
1220     UpdateCrc32:=Crc32Tbl[byte(UpdateCrc32) xor byte(p^)] xor (UpdateCrc32 shr 8);
1221     inc(p);
1222   end;
1223  UpdateCrc32:=not UpdateCrc32;
1224end;
1225
1226
1227{****************************************************************************
1228                         Generic Executable Open/Close
1229****************************************************************************}
1230
1231type
1232  TOpenProc=function(var e:TExeFile):boolean;
1233  TFindSectionProc=function(var e:TExeFile;const asecname:string;var secofs,seclen:longint):boolean;
1234
1235  TExeProcRec=record
1236    openproc : TOpenProc;
1237    findproc : TFindSectionProc;
1238  end;
1239
1240const
1241  ExeProcs : TExeProcRec = (
1242{$ifdef go32v2}
1243     openproc : @OpenGo32Coff;
1244     findproc : @FindSectionCoff;
1245{$endif}
1246{$ifdef PE32}
1247     openproc : @OpenPeCoff;
1248     findproc : @FindSectionCoff;
1249{$endif}
1250{$ifdef PE32PLUS}
1251     openproc : @OpenPePlusCoff;
1252     findproc : @FindSectionCoff;
1253{$endif PE32PLUS}
1254{$if defined(ELF32) or defined(ELF64)}
1255     openproc : @OpenElf;
1256     findproc : @FindSectionElf;
1257{$endif ELF32 or ELF64}
1258{$ifdef darwin}
1259     openproc : @OpenMachO32PPC;
1260     findproc : @FindSectionMachO32PPC;
1261{$endif darwin}
1262{$IFDEF EMX}
1263     openproc : @OpenEMXaout;
1264     findproc : @FindSectionEMXaout;
1265{$ENDIF EMX}
1266{$ifdef netware}
1267     openproc : @OpenNetwareNLM;
1268     findproc : @FindSectionNetwareNLM;
1269{$endif}
1270   );
1271
1272function OpenExeFile(var e:TExeFile;const fn:string):boolean;
1273var
1274  ofm : word;
1275begin
1276  OpenExeFile:=false;
1277  fillchar(e,sizeof(e),0);
1278  e.bufsize:=sizeof(e.buf);
1279  e.filename:=fn;
1280  if fn='' then   // we don't want to read stdin
1281    exit;
1282  assign(e.f,fn);
1283  {$I-}
1284   ofm:=filemode;
1285   filemode:=$40;
1286   reset(e.f,1);
1287   filemode:=ofm;
1288  {$I+}
1289  if ioresult<>0 then
1290   exit;
1291  e.isopen:=true;
1292  // cache filesize
1293  e.size:=filesize(e.f);
1294
1295  E.FunctionRelative := true;
1296  E.ImgOffset := 0;
1297  if ExeProcs.OpenProc<>nil then
1298    OpenExeFile:=ExeProcs.OpenProc(e);
1299end;
1300
1301
1302function CloseExeFile(var e:TExeFile):boolean;
1303begin
1304  CloseExeFile:=false;
1305  if not e.isopen then
1306    exit;
1307  e.isopen:=false;
1308  close(e.f);
1309  CloseExeFile:=true;
1310end;
1311
1312
1313function FindExeSection(var e:TExeFile;const secname:string;var secofs,seclen:longint):boolean;
1314begin
1315  FindExeSection:=false;
1316  if not e.isopen then
1317    exit;
1318  if ExeProcs.FindProc<>nil then
1319    FindExeSection:=ExeProcs.FindProc(e,secname,secofs,seclen);
1320end;
1321
1322
1323
1324function CheckDbgFile(var e:TExeFile;const fn:string;dbgcrc:cardinal):boolean;
1325var
1326  c      : cardinal;
1327  ofm    : word;
1328  g      : file;
1329begin
1330  CheckDbgFile:=false;
1331  assign(g,fn);
1332  {$I-}
1333   ofm:=filemode;
1334   filemode:=$40;
1335   reset(g,1);
1336   filemode:=ofm;
1337  {$I+}
1338  if ioresult<>0 then
1339   exit;
1340  { We reuse the buffer from e here to prevent too much stack allocation }
1341  c:=0;
1342  repeat
1343    blockread(g,e.buf,e.bufsize,e.bufcnt);
1344    c:=UpdateCrc32(c,e.buf,e.bufcnt);
1345  until e.bufcnt<e.bufsize;
1346  close(g);
1347  CheckDbgFile:=(dbgcrc=c);
1348end;
1349
1350
1351function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
1352var
1353  dbglink : array[0..255] of char;
1354  i,
1355  dbglinklen,
1356  dbglinkofs : longint;
1357  dbgcrc     : cardinal;
1358begin
1359  ReadDebugLink:=false;
1360  if not FindExeSection(e,'.gnu_debuglink',dbglinkofs,dbglinklen) then
1361    exit;
1362  if dbglinklen>sizeof(dbglink)-1 then
1363    exit;
1364  fillchar(dbglink,sizeof(dbglink),0);
1365  seek(e.f,dbglinkofs);
1366  blockread(e.f,dbglink,dbglinklen);
1367  dbgfn:=strpas(dbglink);
1368  if length(dbgfn)=0 then
1369    exit;
1370  i:=align(length(dbgfn)+1,4);
1371  if (i+4)>dbglinklen then
1372    exit;
1373  move(dbglink[i],dbgcrc,4);
1374  { current dir }
1375  if CheckDbgFile(e,dbgfn,dbgcrc) then
1376    begin
1377      ReadDebugLink:=true;
1378      exit;
1379    end;
1380  { executable dir }
1381  i:=length(e.filename);
1382  while (i>0) and not(e.filename[i] in AllowDirectorySeparators) do
1383    dec(i);
1384  if i>0 then
1385    begin
1386      dbgfn:=copy(e.filename,1,i)+dbgfn;
1387      if CheckDbgFile(e,dbgfn,dbgcrc) then
1388        begin
1389          ReadDebugLink:=true;
1390          exit;
1391        end;
1392    end;
1393end;
1394
1395
1396begin
1397{$ifdef FIND_BASEADDR_ELF}
1398  UnixGetModuleByAddrHook:=@GetExeInMemoryBaseAddr;
1399{$endif FIND_BASEADDR_ELF}
1400end.
1401