source: ExceptionLogger/CustomLineInfo.pas

Last change on this file was 418, checked in by chronos, 13 years ago
  • Fixed: Show debug info from external debug file in exception handling.
File size: 10.4 KB
Line 
1{
2 This file is part of the Free Pascal run time library.
3 Copyright (c) 2000 by Peter Vreman
4
5 Stabs Line Info Retriever
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}
19unit CustomLineInfo;
20interface
21
22{$S-}
23{$Q-}
24
25function GetLineInfo(addr:ptruint;var func,source:shortstring;var line:longint) : boolean;
26function StabBackTraceStr(addr:Pointer):shortstring;
27
28implementation
29
30uses
31 exeinfo,strings;
32
33const
34 N_Function = $24;
35 N_TextLine = $44;
36 N_DataLine = $46;
37 N_BssLine = $48;
38 N_SourceFile = $64;
39 N_IncludeFile = $84;
40
41 maxstabs = 40; { size of the stabs buffer }
42
43var
44 { GDB after 4.18 uses offset to function begin
45 in text section but OS/2 version still uses 4.16 PM }
46 StabsFunctionRelative: boolean;
47
48type
49 pstab=^tstab;
50 tstab=packed record
51 strpos : longint;
52 ntype : byte;
53 nother : byte;
54 ndesc : word;
55 nvalue : dword;
56 end;
57
58{ We use static variable so almost no stack is required, and is thus
59 more safe when an error has occured in the program }
60var
61 e : TExeFile;
62 stabcnt, { amount of stabs }
63 stablen,
64 stabofs, { absolute stab section offset in executable }
65 stabstrlen,
66 stabstrofs : longint; { absolute stabstr section offset in executable }
67 dirlength : longint; { length of the dirctory part of the source file }
68 stabs : array[0..maxstabs-1] of tstab; { buffer }
69 funcstab, { stab with current function info }
70 linestab, { stab with current line info }
71 dirstab, { stab with current directory info }
72 filestab : tstab; { stab with current file info }
73 filename: shortstring;
74 dbgfn : string;
75
76
77var
78 Crc32Tbl : array[0..255] of cardinal;
79
80procedure MakeCRC32Tbl;
81var
82 crc : cardinal;
83 i,n : integer;
84begin
85 for i:=0 to 255 do
86 begin
87 crc:=i;
88 for n:=1 to 8 do
89 if (crc and 1)<>0 then
90 crc:=(crc shr 1) xor cardinal($edb88320)
91 else
92 crc:=crc shr 1;
93 Crc32Tbl[i]:=crc;
94 end;
95end;
96
97Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:LongInt):cardinal;
98 var
99 i : LongInt;
100 p : pchar;
101 begin
102 if Crc32Tbl[1]=0 then
103 MakeCrc32Tbl;
104 p:=@InBuf;
105 Result:=not InitCrc;
106 for i:=1 to InLen do
107 begin
108 UpdateCrc32:=Crc32Tbl[byte(Result) xor byte(p^)] xor (Result shr 8);
109 inc(p);
110 end;
111 Result:=not Result;
112 end;
113
114 function CheckDbgFile(var e:TExeFile;const fn:string;dbgcrc:cardinal):boolean;
115 var
116 c : cardinal;
117 ofm : word;
118 g : file;
119 begin
120 CheckDbgFile:=false;
121 assign(g,fn);
122 {$I-}
123 ofm:=filemode;
124 filemode:=$40;
125 reset(g,1);
126 filemode:=ofm;
127 {$I+}
128 if ioresult<>0 then
129 exit;
130 { We reuse the buffer from e here to prevent too much stack allocation }
131 c:=0;
132 repeat
133 blockread(g,e.buf,e.bufsize,e.bufcnt);
134 c:=UpdateCrc32(c,e.buf,e.bufcnt);
135 until e.bufcnt<e.bufsize;
136 close(g);
137 CheckDbgFile:=(dbgcrc=c);
138 end;
139
140 function ReadDebugLink(var e:TExeFile;var dbgfn:string):boolean;
141 var
142 dbglink : array[0..512] of char;
143 i,
144 dbglinklen,
145 dbglinkofs : longint;
146 dbgcrc : cardinal;
147 begin
148 ReadDebugLink:=false;
149 if not FindExeSection(e,'.gnu_debuglink',dbglinkofs,dbglinklen) then
150 exit;
151 if dbglinklen>sizeof(dbglink)-1 then
152 exit;
153 fillchar(dbglink,sizeof(dbglink),0);
154 seek(e.f,dbglinkofs);
155 blockread(e.f,dbglink,dbglinklen);
156 dbgfn:=strpas(dbglink);
157 if length(dbgfn)=0 then
158 exit;
159 i:=align(length(dbgfn)+1,4);
160 if (i+4)>dbglinklen then
161 exit;
162 move(dbglink[i],dbgcrc,4);
163 { current dir }
164 if CheckDbgFile(e,dbgfn,dbgcrc) then
165 begin
166 ReadDebugLink:=true;
167 exit;
168 end;
169 { executable dir }
170 i:=length(e.filename);
171 while (i>0) and not(e.filename[i] in AllowDirectorySeparators) do
172 dec(i);
173 if i>0 then
174 begin
175 dbgfn:=copy(e.filename,1,i)+dbgfn;
176 if CheckDbgFile(e,dbgfn,dbgcrc) then
177 begin
178 ReadDebugLink:=true;
179 exit;
180 end;
181 end;
182 end;
183
184function OpenStabs(addr : pointer) : boolean;
185 var
186 baseaddr : pointer;
187begin
188 OpenStabs:=false;
189
190 GetModuleByAddr(addr,baseaddr,filename);
191{$ifdef DEBUG_LINEINFO}
192 writeln(stderr,filename,' Baseaddr: ',hexstr(ptruint(baseaddr),sizeof(baseaddr)*2));
193{$endif DEBUG_LINEINFO}
194
195 if not OpenExeFile(e,filename) then
196 exit;
197 if ReadDebugLink(e,dbgfn) then
198 begin
199 CloseExeFile(e);
200 if not OpenExeFile(e,dbgfn) then
201 exit;
202 end;
203 if ptruint(BaseAddr) < e.processaddress then Exit;
204
205 e.processaddress := ptruint(baseaddr) - e.processaddress;
206 StabsFunctionRelative := E.FunctionRelative;
207 if FindExeSection(e,'.stab',stabofs,stablen) and
208 FindExeSection(e,'.stabstr',stabstrofs,stabstrlen) then
209 begin
210 stabcnt:=stablen div sizeof(tstab);
211 OpenStabs:=true;
212 end
213 else
214 begin
215 CloseExeFile(e);
216 exit;
217 end;
218end;
219
220procedure CloseStabs;
221begin
222 CloseExeFile(e);
223end;
224
225function GetLineInfo(addr:ptruint;var func,source:shortstring;var line:longint) : boolean;
226var
227 res,
228 stabsleft,
229 stabscnt,i : longint;
230 found : boolean;
231 lastfunc : tstab;
232begin
233 GetLineInfo:=false;
234{$ifdef DEBUG_LINEINFO}
235 writeln(stderr,'GetLineInfo called');
236{$endif DEBUG_LINEINFO}
237 fillchar(func,high(func)+1,0);
238 fillchar(source,high(source)+1,0);
239 line:=0;
240 if not e.isopen then
241 begin
242 if not OpenStabs(pointer(addr)) then
243 exit;
244 end;
245
246 { correct the value to the correct address in the file }
247 { processaddress is set in OpenStabs }
248 addr := dword(addr - e.processaddress);
249
250{$ifdef DEBUG_LINEINFO}
251 writeln(stderr,'Addr: ',hexstr(addr,sizeof(addr)*2));
252{$endif DEBUG_LINEINFO}
253
254 fillchar(funcstab,sizeof(tstab),0);
255 fillchar(filestab,sizeof(tstab),0);
256 fillchar(dirstab,sizeof(tstab),0);
257 fillchar(linestab,sizeof(tstab),0);
258 fillchar(lastfunc,sizeof(tstab),0);
259 found:=false;
260 seek(e.f,stabofs);
261 stabsleft:=stabcnt;
262 repeat
263 if stabsleft>maxstabs then
264 stabscnt:=maxstabs
265 else
266 stabscnt:=stabsleft;
267 blockread(e.f,stabs,stabscnt*sizeof(tstab),res);
268 stabscnt:=res div sizeof(tstab);
269 for i:=0 to stabscnt-1 do
270 begin
271 case stabs[i].ntype of
272 N_BssLine,
273 N_DataLine,
274 N_TextLine :
275 begin
276 if (stabs[i].ntype=N_TextLine) and StabsFunctionRelative then
277 inc(stabs[i].nvalue,lastfunc.nvalue);
278 if (stabs[i].nvalue<=addr) and
279 (stabs[i].nvalue>linestab.nvalue) then
280 begin
281 { if it's equal we can stop and take the last info }
282 if stabs[i].nvalue=addr then
283 found:=true
284 else
285 linestab:=stabs[i];
286 end;
287 end;
288 N_Function :
289 begin
290 lastfunc:=stabs[i];
291 if (stabs[i].nvalue<=addr) and
292 (stabs[i].nvalue>funcstab.nvalue) then
293 begin
294 funcstab:=stabs[i];
295 fillchar(linestab,sizeof(tstab),0);
296 end;
297 end;
298 N_SourceFile,
299 N_IncludeFile :
300 begin
301 if (stabs[i].nvalue<=addr) and
302 (stabs[i].nvalue>=filestab.nvalue) then
303 begin
304 { if same value and type then the first one
305 contained the directory PM }
306 if (stabs[i].nvalue=filestab.nvalue) and
307 (stabs[i].ntype=filestab.ntype) then
308 dirstab:=filestab
309 else
310 fillchar(dirstab,sizeof(tstab),0);
311 filestab:=stabs[i];
312 fillchar(linestab,sizeof(tstab),0);
313 { if new file then func is not valid anymore PM }
314 if stabs[i].ntype=N_SourceFile then
315 begin
316 fillchar(funcstab,sizeof(tstab),0);
317 fillchar(lastfunc,sizeof(tstab),0);
318 end;
319 end;
320 end;
321 end;
322 end;
323 dec(stabsleft,stabscnt);
324 until found or (stabsleft=0);
325
326{ get the line,source,function info }
327 line:=linestab.ndesc;
328 if dirstab.ntype<>0 then
329 begin
330 seek(e.f,stabstrofs+dirstab.strpos);
331 blockread(e.f,source[1],high(source)-1,res);
332 dirlength:=strlen(@source[1]);
333 source[0]:=chr(dirlength);
334 end
335 else
336 dirlength:=0;
337 if filestab.ntype<>0 then
338 begin
339 seek(e.f,stabstrofs+filestab.strpos);
340 blockread(e.f,source[dirlength+1],high(source)-(dirlength+1),res);
341 source[0]:=chr(strlen(@source[1]));
342 end;
343 if funcstab.ntype<>0 then
344 begin
345 seek(e.f,stabstrofs+funcstab.strpos);
346 blockread(e.f,func[1],high(func)-1,res);
347 func[0]:=chr(strlen(@func[1]));
348 i:=pos(':',func);
349 if i>0 then
350 Delete(func,i,255);
351 end;
352// if e.isopen then
353// CloseStabs;
354 GetLineInfo:=true;
355end;
356
357function StabBackTraceStr(addr:Pointer):shortstring;
358var
359 func,
360 source : shortstring;
361 hs : string[32];
362 line : longint;
363 Store : TBackTraceStrFunc;
364 Success : boolean;
365begin
366{$ifdef DEBUG_LINEINFO}
367 writeln(stderr,'StabBackTraceStr called');
368{$endif DEBUG_LINEINFO}
369 { reset to prevent infinite recursion if problems inside the code PM }
370 Success:=false;
371 Store:=BackTraceStrFunc;
372 BackTraceStrFunc:=@SysBackTraceStr;
373 Success:=GetLineInfo(ptruint(addr),func,source,line);
374{ create string }
375{$ifdef netware}
376 { we need addr relative to code start on netware }
377 dec(addr,ptruint(system.NWGetCodeStart));
378 StabBackTraceStr:=' CodeStart + $'+HexStr(ptruint(addr),sizeof(ptruint)*2);
379{$else}
380 StabBackTraceStr:=' $'+HexStr(ptruint(addr),sizeof(ptruint)*2);
381{$endif}
382 if func<>'' then
383 Result := Result +' '+func;
384 if source<>'' then
385 begin
386 if func<>'' then
387 Result := Result + ', ';
388 if line<>0 then
389 begin
390 str(line,hs);
391 Result := Result + ' line ' + hs;
392 end;
393 Result := Result + ' of ' + source;
394 end;
395 if Success then
396 BackTraceStrFunc:=Store;
397end;
398
399initialization
400 BackTraceStrFunc := @StabBackTraceStr;
401
402finalization
403 if e.isopen then
404 CloseStabs;
405end.
Note: See TracBrowser for help on using the repository browser.