Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* deb.c |
79072805 | 2 | * |
1129b882 NC |
3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, |
4 | * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others | |
79072805 LW |
5 | * |
6 | * You may distribute under the terms of either the GNU General Public | |
7 | * License or the Artistic License, as specified in the README file. | |
8 | * | |
a0d0e21e LW |
9 | */ |
10 | ||
11 | /* | |
4ac71550 TC |
12 | * 'Didst thou think that the eyes of the White Tower were blind? Nay, |
13 | * I have seen more than thou knowest, Grey Fool.' --Denethor | |
14 | * | |
15 | * [p.853 of _The Lord of the Rings_, V/vii: "The Pyre of Denethor"] | |
79072805 LW |
16 | */ |
17 | ||
166f8a29 | 18 | /* |
61296642 DM |
19 | * This file contains various utilities for producing debugging output |
20 | * (mainly related to displaying the stack) | |
166f8a29 DM |
21 | */ |
22 | ||
79072805 | 23 | #include "EXTERN.h" |
864dbfa3 | 24 | #define PERL_IN_DEB_C |
79072805 LW |
25 | #include "perl.h" |
26 | ||
6e512bc2 | 27 | #if defined(MULTIPLICITY) |
c5be433b GS |
28 | void |
29 | Perl_deb_nocontext(const char *pat, ...) | |
30 | { | |
31 | #ifdef DEBUGGING | |
32 | dTHX; | |
33 | va_list args; | |
7918f24d | 34 | PERL_ARGS_ASSERT_DEB_NOCONTEXT; |
c5be433b GS |
35 | va_start(args, pat); |
36 | vdeb(pat, &args); | |
37 | va_end(args); | |
5f66b61c AL |
38 | #else |
39 | PERL_UNUSED_ARG(pat); | |
c5be433b GS |
40 | #endif /* DEBUGGING */ |
41 | } | |
42 | #endif | |
43 | ||
7aa7cc79 KW |
44 | /* |
45 | =for apidoc deb | |
46 | =for apidoc_item deb_nocontext | |
47 | ||
48 | When perl is compiled with C<-DDEBUGGING>, this prints to STDERR the | |
49 | information given by the arguments, prefaced by the name of the file containing | |
50 | the script causing the call, and the line number within that file. | |
51 | ||
52 | If the C<v> (verbose) debugging option is in effect, the process id is also | |
53 | printed. | |
54 | ||
55 | The two forms differ only in that C<deb_nocontext> does not take a thread | |
56 | context (C<aTHX>) parameter, so is used in situations where the caller doesn't | |
57 | already have the thread context. | |
58 | ||
59 | =cut | |
60 | */ | |
61 | ||
8990e307 | 62 | void |
864dbfa3 | 63 | Perl_deb(pTHX_ const char *pat, ...) |
79072805 LW |
64 | { |
65 | va_list args; | |
7918f24d | 66 | PERL_ARGS_ASSERT_DEB; |
c5be433b | 67 | va_start(args, pat); |
fe5bfecd | 68 | #ifdef DEBUGGING |
c5be433b | 69 | vdeb(pat, &args); |
65e66c80 | 70 | #else |
96a5add6 | 71 | PERL_UNUSED_CONTEXT; |
c5be433b | 72 | #endif /* DEBUGGING */ |
fe5bfecd | 73 | va_end(args); |
c5be433b GS |
74 | } |
75 | ||
7aa7cc79 KW |
76 | /* |
77 | =for apidoc vdeb | |
78 | ||
79 | This is like C<L</deb>>, but C<args> are an encapsulated argument list. | |
80 | ||
81 | =cut | |
82 | */ | |
83 | ||
c5be433b GS |
84 | void |
85 | Perl_vdeb(pTHX_ const char *pat, va_list *args) | |
86 | { | |
87 | #ifdef DEBUGGING | |
185c8bac NC |
88 | const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>"; |
89 | const char* const display_file = file ? file : "<free>"; | |
1932805f | 90 | line_t line = PL_curcop ? CopLINE(PL_curcop) : NOLINE; |
e772cf34 YO |
91 | if (line == NOLINE) |
92 | line = 0; | |
79072805 | 93 | |
7918f24d NC |
94 | PERL_ARGS_ASSERT_VDEB; |
95 | ||
185c8bac | 96 | if (DEBUG_v_TEST) |
1932805f | 97 | PerlIO_printf(Perl_debug_log, "(%ld:%s:%" LINE_Tf ")\t", |
1604cfb0 | 98 | (long)PerlProc_getpid(), display_file, line); |
185c8bac | 99 | else |
1932805f TK |
100 | PerlIO_printf(Perl_debug_log, "(%s:%" LINE_Tf ")\t", |
101 | display_file, line); | |
c5be433b | 102 | (void) PerlIO_vprintf(Perl_debug_log, pat, *args); |
65e66c80 | 103 | #else |
96a5add6 | 104 | PERL_UNUSED_CONTEXT; |
65e66c80 SP |
105 | PERL_UNUSED_ARG(pat); |
106 | PERL_UNUSED_ARG(args); | |
17c3b450 | 107 | #endif /* DEBUGGING */ |
79072805 | 108 | } |
79072805 | 109 | |
79072805 | 110 | I32 |
59e6561a | 111 | Perl_debstackptrs(pTHX) /* Currently unused in cpan and core */ |
79072805 | 112 | { |
17c3b450 | 113 | #ifdef DEBUGGING |
b900a521 | 114 | PerlIO_printf(Perl_debug_log, |
1604cfb0 MS |
115 | "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", |
116 | PTR2UV(PL_curstack), PTR2UV(PL_stack_base), | |
117 | (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), | |
118 | (IV)(PL_stack_max-PL_stack_base)); | |
b900a521 | 119 | PerlIO_printf(Perl_debug_log, |
1604cfb0 MS |
120 | "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", |
121 | PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), | |
122 | PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), | |
123 | PTR2UV(AvMAX(PL_curstack))); | |
81611534 JH |
124 | #else |
125 | PERL_UNUSED_CONTEXT; | |
17c3b450 | 126 | #endif /* DEBUGGING */ |
79072805 LW |
127 | return 0; |
128 | } | |
129 | ||
a0d0e21e | 130 | |
d6721266 DM |
131 | /* dump the contents of a particular stack |
132 | * Display stack_base[stack_min+1 .. stack_max], | |
133 | * and display the marks whose offsets are contained in addresses | |
134 | * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range | |
135 | * of the stack values being displayed | |
f8fc6b09 DM |
136 | * On PERL_RC_STACK builds, nonrc_base indicates the lowest |
137 | * non-reference-counted stack element (or 0 if none or not such a build). | |
138 | * Display a vertical bar at this position. | |
d6721266 DM |
139 | * |
140 | * Only displays top 30 max | |
141 | */ | |
1045810a | 142 | |
d6721266 | 143 | STATIC void |
c0588928 TC |
144 | S_deb_stack_n(pTHX_ SV** stack_base, SSize_t stack_min, SSize_t stack_max, |
145 | SSize_t mark_min, SSize_t mark_max, SSize_t nonrc_base) | |
d6721266 DM |
146 | { |
147 | #ifdef DEBUGGING | |
c0588928 | 148 | SSize_t i = stack_max - 30; |
a1ab4f2e | 149 | const Stack_off_t *markscan = PL_markstack + mark_min; |
7918f24d NC |
150 | |
151 | PERL_ARGS_ASSERT_DEB_STACK_N; | |
152 | ||
d6721266 | 153 | if (i < stack_min) |
1604cfb0 | 154 | i = stack_min; |
a0d0e21e | 155 | |
d6721266 | 156 | while (++markscan <= PL_markstack + mark_max) |
1604cfb0 MS |
157 | if (*markscan >= i) |
158 | break; | |
79072805 | 159 | |
d6721266 | 160 | if (i > stack_min) |
1604cfb0 | 161 | PerlIO_printf(Perl_debug_log, "... "); |
d6721266 DM |
162 | |
163 | if (stack_base[0] != &PL_sv_undef || stack_max < 0) | |
1604cfb0 | 164 | PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); |
a0d0e21e | 165 | do { |
1604cfb0 MS |
166 | ++i; |
167 | if (markscan <= PL_markstack + mark_max && *markscan < i) { | |
168 | do { | |
169 | ++markscan; | |
170 | (void)PerlIO_putc(Perl_debug_log, '*'); | |
171 | } | |
172 | while (markscan <= PL_markstack + mark_max && *markscan < i); | |
173 | PerlIO_printf(Perl_debug_log, " "); | |
174 | } | |
175 | if (i > stack_max) | |
176 | break; | |
f8fc6b09 | 177 | |
1604cfb0 | 178 | PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); |
f8fc6b09 DM |
179 | |
180 | if (nonrc_base && nonrc_base == i + 1) | |
181 | PerlIO_printf(Perl_debug_log, "| "); | |
79072805 | 182 | } |
a0d0e21e | 183 | while (1); |
760ac839 | 184 | PerlIO_printf(Perl_debug_log, "\n"); |
65e66c80 | 185 | #else |
96a5add6 | 186 | PERL_UNUSED_CONTEXT; |
65e66c80 SP |
187 | PERL_UNUSED_ARG(stack_base); |
188 | PERL_UNUSED_ARG(stack_min); | |
189 | PERL_UNUSED_ARG(stack_max); | |
190 | PERL_UNUSED_ARG(mark_min); | |
191 | PERL_UNUSED_ARG(mark_max); | |
f8fc6b09 | 192 | PERL_UNUSED_ARG(nonrc_base); |
d6721266 DM |
193 | #endif /* DEBUGGING */ |
194 | } | |
195 | ||
196 | ||
8566922c KW |
197 | /* |
198 | =for apidoc debstack | |
199 | ||
200 | Dump the current stack | |
201 | ||
202 | =cut | |
203 | */ | |
d6721266 DM |
204 | |
205 | I32 | |
206 | Perl_debstack(pTHX) | |
207 | { | |
208 | #ifndef SKIP_DEBUGGING | |
209 | if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) | |
1604cfb0 | 210 | return 0; |
d6721266 DM |
211 | |
212 | PerlIO_printf(Perl_debug_log, " => "); | |
f8fc6b09 | 213 | S_deb_stack_n(aTHX_ PL_stack_base, |
1604cfb0 MS |
214 | 0, |
215 | PL_stack_sp - PL_stack_base, | |
216 | PL_curstackinfo->si_markoff, | |
f8fc6b09 DM |
217 | PL_markstack_ptr - PL_markstack, |
218 | # ifdef PERL_RC_STACK | |
219 | PL_curstackinfo->si_stack_nonrc_base | |
220 | # else | |
221 | 0 | |
222 | # endif | |
223 | ); | |
d6721266 DM |
224 | |
225 | ||
1045810a | 226 | #endif /* SKIP_DEBUGGING */ |
79072805 LW |
227 | return 0; |
228 | } | |
d6721266 DM |
229 | |
230 | ||
231 | #ifdef DEBUGGING | |
0bd48802 | 232 | static const char * const si_names[] = { |
d6721266 DM |
233 | "UNKNOWN", |
234 | "UNDEF", | |
235 | "MAIN", | |
236 | "MAGIC", | |
237 | "SORT", | |
238 | "SIGNAL", | |
239 | "OVERLOAD", | |
240 | "DESTROY", | |
241 | "WARNHOOK", | |
242 | "DIEHOOK", | |
00898ccb | 243 | "REQUIRE", |
e1a10f35 | 244 | "MULTICALL" |
d6721266 DM |
245 | }; |
246 | #endif | |
247 | ||
248 | /* display all stacks */ | |
249 | ||
250 | ||
251 | void | |
252 | Perl_deb_stack_all(pTHX) | |
253 | { | |
254 | #ifdef DEBUGGING | |
0bd48802 | 255 | I32 si_ix; |
7452cf6a | 256 | const PERL_SI *si; |
d6721266 DM |
257 | |
258 | /* rewind to start of chain */ | |
259 | si = PL_curstackinfo; | |
260 | while (si->si_prev) | |
1604cfb0 | 261 | si = si->si_prev; |
d6721266 DM |
262 | |
263 | si_ix=0; | |
264 | for (;;) | |
265 | { | |
bb7a0f54 | 266 | const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ |
00b25eff JH |
267 | const char * const si_name = |
268 | si_name_ix < C_ARRAY_LENGTH(si_names) ? | |
269 | si_names[si_name_ix] : "????"; | |
1604cfb0 | 270 | I32 ix; |
f8fc6b09 DM |
271 | PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s%s\n", |
272 | (IV)si_ix, si_name, | |
273 | # ifdef PERL_RC_STACK | |
274 | AvREAL(si->si_stack) | |
275 | ? (si->si_stack_nonrc_base ? " (partial real)" : " (real)") | |
276 | : "" | |
277 | # else | |
278 | "" | |
279 | # endif | |
280 | ); | |
1604cfb0 MS |
281 | |
282 | for (ix=0; ix<=si->si_cxix; ix++) { | |
283 | ||
284 | const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); | |
285 | PerlIO_printf(Perl_debug_log, | |
286 | " CX %" IVdf ": %-6s => ", | |
287 | (IV)ix, PL_block_type[CxTYPE(cx)] | |
288 | ); | |
289 | /* substitution contexts don't save stack pointers etc) */ | |
290 | if (CxTYPE(cx) == CXt_SUBST) | |
291 | PerlIO_printf(Perl_debug_log, "\n"); | |
292 | else { | |
293 | ||
294 | /* Find the current context's stack range by searching | |
295 | * forward for any higher contexts using this stack; failing | |
296 | * that, it will be equal to the size of the stack for old | |
297 | * stacks, or PL_stack_sp for the current stack | |
298 | */ | |
299 | ||
300 | I32 i, stack_min, stack_max, mark_min, mark_max; | |
301 | const PERL_CONTEXT *cx_n = NULL; | |
302 | const PERL_SI *si_n; | |
d6721266 | 303 | |
5ef71089 DM |
304 | /* there's a separate argument stack per SI, so only |
305 | * search this one */ | |
d6721266 | 306 | |
1604cfb0 | 307 | for (i=ix+1; i<=si->si_cxix; i++) { |
5ef71089 DM |
308 | const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); |
309 | if (CxTYPE(this_cx) == CXt_SUBST) | |
1604cfb0 MS |
310 | continue; |
311 | cx_n = this_cx; | |
312 | break; | |
313 | } | |
314 | ||
315 | stack_min = cx->blk_oldsp; | |
316 | ||
317 | if (cx_n) { | |
318 | stack_max = cx_n->blk_oldsp; | |
319 | } | |
320 | else if (si == PL_curstackinfo) { | |
321 | stack_max = PL_stack_sp - AvARRAY(si->si_stack); | |
322 | } | |
323 | else { | |
324 | stack_max = AvFILLp(si->si_stack); | |
325 | } | |
d6721266 | 326 | |
5ef71089 DM |
327 | /* for the markstack, there's only one stack shared |
328 | * between all SIs */ | |
d6721266 | 329 | |
1604cfb0 MS |
330 | si_n = si; |
331 | i = ix; | |
332 | cx_n = NULL; | |
333 | for (;;) { | |
334 | i++; | |
335 | if (i > si_n->si_cxix) { | |
336 | if (si_n == PL_curstackinfo) | |
337 | break; | |
338 | else { | |
339 | si_n = si_n->si_next; | |
340 | i = 0; | |
341 | } | |
342 | } | |
343 | if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) | |
344 | continue; | |
504d203b DM |
345 | if (si_n->si_cxix >= 0) |
346 | cx_n = &(si_n->si_cxstack[i]); | |
347 | else | |
348 | cx_n = NULL; | |
1604cfb0 MS |
349 | break; |
350 | } | |
351 | ||
352 | mark_min = cx->blk_oldmarksp; | |
353 | if (cx_n) { | |
354 | mark_max = cx_n->blk_oldmarksp; | |
355 | } | |
356 | else { | |
357 | mark_max = PL_markstack_ptr - PL_markstack; | |
358 | } | |
359 | ||
f8fc6b09 DM |
360 | S_deb_stack_n(aTHX_ AvARRAY(si->si_stack), |
361 | stack_min, stack_max, mark_min, mark_max, | |
362 | # ifdef PERL_RC_STACK | |
363 | si->si_stack_nonrc_base | |
364 | # else | |
365 | 0 | |
366 | # endif | |
367 | ); | |
1604cfb0 MS |
368 | |
369 | if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB | |
370 | || CxTYPE(cx) == CXt_FORMAT) | |
371 | { | |
372 | const OP * const retop = cx->blk_sub.retop; | |
373 | ||
374 | PerlIO_printf(Perl_debug_log, " retop=%s\n", | |
375 | retop ? OP_NAME(retop) : "(null)" | |
376 | ); | |
377 | } | |
378 | } | |
379 | } /* next context */ | |
380 | ||
381 | ||
382 | if (si == PL_curstackinfo) | |
383 | break; | |
384 | si = si->si_next; | |
385 | si_ix++; | |
386 | if (!si) | |
387 | break; /* shouldn't happen, but just in case.. */ | |
d6721266 DM |
388 | } /* next stackinfo */ |
389 | ||
390 | PerlIO_printf(Perl_debug_log, "\n"); | |
96a5add6 AL |
391 | #else |
392 | PERL_UNUSED_CONTEXT; | |
d6721266 DM |
393 | #endif /* DEBUGGING */ |
394 | } | |
395 | ||
66610fdd | 396 | /* |
14d04a33 | 397 | * ex: set ts=8 sts=4 sw=4 et: |
37442d52 | 398 | */ |