1 /* deb.c
2 *
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
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 *
9 */
10
11 /*
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"]
16 */
17
18 /*
19 * This file contains various utilities for producing debugging output
20 * (mainly related to displaying the stack)
21 */
22
23 #include "EXTERN.h"
24 #define PERL_IN_DEB_C
25 #include "perl.h"
26
27 #if defined(MULTIPLICITY)
28 void
Perl_deb_nocontext(const char * pat,...)29 Perl_deb_nocontext(const char *pat, ...)
30 {
31 #ifdef DEBUGGING
32 dTHX;
33 va_list args;
34 PERL_ARGS_ASSERT_DEB_NOCONTEXT;
35 va_start(args, pat);
36 vdeb(pat, &args);
37 va_end(args);
38 #else
39 PERL_UNUSED_ARG(pat);
40 #endif /* DEBUGGING */
41 }
42 #endif
43
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
62 void
Perl_deb(pTHX_ const char * pat,...)63 Perl_deb(pTHX_ const char *pat, ...)
64 {
65 va_list args;
66 PERL_ARGS_ASSERT_DEB;
67 va_start(args, pat);
68 #ifdef DEBUGGING
69 vdeb(pat, &args);
70 #else
71 PERL_UNUSED_CONTEXT;
72 #endif /* DEBUGGING */
73 va_end(args);
74 }
75
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
84 void
Perl_vdeb(pTHX_ const char * pat,va_list * args)85 Perl_vdeb(pTHX_ const char *pat, va_list *args)
86 {
87 #ifdef DEBUGGING
88 const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
89 const char* const display_file = file ? file : "<free>";
90 line_t line = PL_curcop ? CopLINE(PL_curcop) : NOLINE;
91 if (line == NOLINE)
92 line = 0;
93
94 PERL_ARGS_ASSERT_VDEB;
95
96 if (DEBUG_v_TEST)
97 PerlIO_printf(Perl_debug_log, "(%ld:%s:%" LINE_Tf ")\t",
98 (long)PerlProc_getpid(), display_file, line);
99 else
100 PerlIO_printf(Perl_debug_log, "(%s:%" LINE_Tf ")\t",
101 display_file, line);
102 (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
103 #else
104 PERL_UNUSED_CONTEXT;
105 PERL_UNUSED_ARG(pat);
106 PERL_UNUSED_ARG(args);
107 #endif /* DEBUGGING */
108 }
109
110 I32
Perl_debstackptrs(pTHX)111 Perl_debstackptrs(pTHX) /* Currently unused in cpan and core */
112 {
113 #ifdef DEBUGGING
114 PerlIO_printf(Perl_debug_log,
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));
119 PerlIO_printf(Perl_debug_log,
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)));
124 #else
125 PERL_UNUSED_CONTEXT;
126 #endif /* DEBUGGING */
127 return 0;
128 }
129
130
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
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.
139 *
140 * Only displays top 30 max
141 */
142
143 STATIC void
S_deb_stack_n(pTHX_ SV ** stack_base,SSize_t stack_min,SSize_t stack_max,SSize_t mark_min,SSize_t mark_max,SSize_t nonrc_base)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)
146 {
147 #ifdef DEBUGGING
148 SSize_t i = stack_max - 30;
149 const Stack_off_t *markscan = PL_markstack + mark_min;
150
151 PERL_ARGS_ASSERT_DEB_STACK_N;
152
153 if (i < stack_min)
154 i = stack_min;
155
156 while (++markscan <= PL_markstack + mark_max)
157 if (*markscan >= i)
158 break;
159
160 if (i > stack_min)
161 PerlIO_printf(Perl_debug_log, "... ");
162
163 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
164 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
165 do {
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;
177
178 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
179
180 if (nonrc_base && nonrc_base == i + 1)
181 PerlIO_printf(Perl_debug_log, "| ");
182 }
183 while (1);
184 PerlIO_printf(Perl_debug_log, "\n");
185 #else
186 PERL_UNUSED_CONTEXT;
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);
192 PERL_UNUSED_ARG(nonrc_base);
193 #endif /* DEBUGGING */
194 }
195
196
197 /*
198 =for apidoc debstack
199
200 Dump the current stack
201
202 =cut
203 */
204
205 I32
Perl_debstack(pTHX)206 Perl_debstack(pTHX)
207 {
208 #ifndef SKIP_DEBUGGING
209 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
210 return 0;
211
212 PerlIO_printf(Perl_debug_log, " => ");
213 S_deb_stack_n(aTHX_ PL_stack_base,
214 0,
215 PL_stack_sp - PL_stack_base,
216 PL_curstackinfo->si_markoff,
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 );
224
225
226 #endif /* SKIP_DEBUGGING */
227 return 0;
228 }
229
230
231 #ifdef DEBUGGING
232 static const char * const si_names[] = {
233 "UNKNOWN",
234 "UNDEF",
235 "MAIN",
236 "MAGIC",
237 "SORT",
238 "SIGNAL",
239 "OVERLOAD",
240 "DESTROY",
241 "WARNHOOK",
242 "DIEHOOK",
243 "REQUIRE",
244 "MULTICALL"
245 };
246 #endif
247
248 /* display all stacks */
249
250
251 void
Perl_deb_stack_all(pTHX)252 Perl_deb_stack_all(pTHX)
253 {
254 #ifdef DEBUGGING
255 I32 si_ix;
256 const PERL_SI *si;
257
258 /* rewind to start of chain */
259 si = PL_curstackinfo;
260 while (si->si_prev)
261 si = si->si_prev;
262
263 si_ix=0;
264 for (;;)
265 {
266 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
267 const char * const si_name =
268 si_name_ix < C_ARRAY_LENGTH(si_names) ?
269 si_names[si_name_ix] : "????";
270 I32 ix;
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 );
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;
303
304 /* there's a separate argument stack per SI, so only
305 * search this one */
306
307 for (i=ix+1; i<=si->si_cxix; i++) {
308 const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]);
309 if (CxTYPE(this_cx) == CXt_SUBST)
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 }
326
327 /* for the markstack, there's only one stack shared
328 * between all SIs */
329
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;
345 if (si_n->si_cxix >= 0)
346 cx_n = &(si_n->si_cxstack[i]);
347 else
348 cx_n = NULL;
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
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 );
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.. */
388 } /* next stackinfo */
389
390 PerlIO_printf(Perl_debug_log, "\n");
391 #else
392 PERL_UNUSED_CONTEXT;
393 #endif /* DEBUGGING */
394 }
395
396 /*
397 * ex: set ts=8 sts=4 sw=4 et:
398 */
399