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 *
137 * Only displays top 30 max
138 */
139
140 STATIC void
S_deb_stack_n(pTHX_ SV ** stack_base,I32 stack_min,I32 stack_max,I32 mark_min,I32 mark_max)141 S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
142 I32 mark_min, I32 mark_max)
143 {
144 #ifdef DEBUGGING
145 I32 i = stack_max - 30;
146 const I32 *markscan = PL_markstack + mark_min;
147
148 PERL_ARGS_ASSERT_DEB_STACK_N;
149
150 if (i < stack_min)
151 i = stack_min;
152
153 while (++markscan <= PL_markstack + mark_max)
154 if (*markscan >= i)
155 break;
156
157 if (i > stack_min)
158 PerlIO_printf(Perl_debug_log, "... ");
159
160 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
161 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
162 do {
163 ++i;
164 if (markscan <= PL_markstack + mark_max && *markscan < i) {
165 do {
166 ++markscan;
167 (void)PerlIO_putc(Perl_debug_log, '*');
168 }
169 while (markscan <= PL_markstack + mark_max && *markscan < i);
170 PerlIO_printf(Perl_debug_log, " ");
171 }
172 if (i > stack_max)
173 break;
174 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
175 }
176 while (1);
177 PerlIO_printf(Perl_debug_log, "\n");
178 #else
179 PERL_UNUSED_CONTEXT;
180 PERL_UNUSED_ARG(stack_base);
181 PERL_UNUSED_ARG(stack_min);
182 PERL_UNUSED_ARG(stack_max);
183 PERL_UNUSED_ARG(mark_min);
184 PERL_UNUSED_ARG(mark_max);
185 #endif /* DEBUGGING */
186 }
187
188
189 /*
190 =for apidoc debstack
191
192 Dump the current stack
193
194 =cut
195 */
196
197 I32
Perl_debstack(pTHX)198 Perl_debstack(pTHX)
199 {
200 #ifndef SKIP_DEBUGGING
201 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
202 return 0;
203
204 PerlIO_printf(Perl_debug_log, " => ");
205 deb_stack_n(PL_stack_base,
206 0,
207 PL_stack_sp - PL_stack_base,
208 PL_curstackinfo->si_markoff,
209 PL_markstack_ptr - PL_markstack);
210
211
212 #endif /* SKIP_DEBUGGING */
213 return 0;
214 }
215
216
217 #ifdef DEBUGGING
218 static const char * const si_names[] = {
219 "UNKNOWN",
220 "UNDEF",
221 "MAIN",
222 "MAGIC",
223 "SORT",
224 "SIGNAL",
225 "OVERLOAD",
226 "DESTROY",
227 "WARNHOOK",
228 "DIEHOOK",
229 "REQUIRE",
230 "MULTICALL"
231 };
232 #endif
233
234 /* display all stacks */
235
236
237 void
Perl_deb_stack_all(pTHX)238 Perl_deb_stack_all(pTHX)
239 {
240 #ifdef DEBUGGING
241 I32 si_ix;
242 const PERL_SI *si;
243
244 /* rewind to start of chain */
245 si = PL_curstackinfo;
246 while (si->si_prev)
247 si = si->si_prev;
248
249 si_ix=0;
250 for (;;)
251 {
252 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
253 const char * const si_name =
254 si_name_ix < C_ARRAY_LENGTH(si_names) ?
255 si_names[si_name_ix] : "????";
256 I32 ix;
257 PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n",
258 (IV)si_ix, si_name);
259
260 for (ix=0; ix<=si->si_cxix; ix++) {
261
262 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
263 PerlIO_printf(Perl_debug_log,
264 " CX %" IVdf ": %-6s => ",
265 (IV)ix, PL_block_type[CxTYPE(cx)]
266 );
267 /* substitution contexts don't save stack pointers etc) */
268 if (CxTYPE(cx) == CXt_SUBST)
269 PerlIO_printf(Perl_debug_log, "\n");
270 else {
271
272 /* Find the current context's stack range by searching
273 * forward for any higher contexts using this stack; failing
274 * that, it will be equal to the size of the stack for old
275 * stacks, or PL_stack_sp for the current stack
276 */
277
278 I32 i, stack_min, stack_max, mark_min, mark_max;
279 const PERL_CONTEXT *cx_n = NULL;
280 const PERL_SI *si_n;
281
282 /* there's a separate argument stack per SI, so only
283 * search this one */
284
285 for (i=ix+1; i<=si->si_cxix; i++) {
286 const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]);
287 if (CxTYPE(this_cx) == CXt_SUBST)
288 continue;
289 cx_n = this_cx;
290 break;
291 }
292
293 stack_min = cx->blk_oldsp;
294
295 if (cx_n) {
296 stack_max = cx_n->blk_oldsp;
297 }
298 else if (si == PL_curstackinfo) {
299 stack_max = PL_stack_sp - AvARRAY(si->si_stack);
300 }
301 else {
302 stack_max = AvFILLp(si->si_stack);
303 }
304
305 /* for the markstack, there's only one stack shared
306 * between all SIs */
307
308 si_n = si;
309 i = ix;
310 cx_n = NULL;
311 for (;;) {
312 i++;
313 if (i > si_n->si_cxix) {
314 if (si_n == PL_curstackinfo)
315 break;
316 else {
317 si_n = si_n->si_next;
318 i = 0;
319 }
320 }
321 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
322 continue;
323 if (si_n->si_cxix >= 0)
324 cx_n = &(si_n->si_cxstack[i]);
325 else
326 cx_n = NULL;
327 break;
328 }
329
330 mark_min = cx->blk_oldmarksp;
331 if (cx_n) {
332 mark_max = cx_n->blk_oldmarksp;
333 }
334 else {
335 mark_max = PL_markstack_ptr - PL_markstack;
336 }
337
338 deb_stack_n(AvARRAY(si->si_stack),
339 stack_min, stack_max, mark_min, mark_max);
340
341 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
342 || CxTYPE(cx) == CXt_FORMAT)
343 {
344 const OP * const retop = cx->blk_sub.retop;
345
346 PerlIO_printf(Perl_debug_log, " retop=%s\n",
347 retop ? OP_NAME(retop) : "(null)"
348 );
349 }
350 }
351 } /* next context */
352
353
354 if (si == PL_curstackinfo)
355 break;
356 si = si->si_next;
357 si_ix++;
358 if (!si)
359 break; /* shouldn't happen, but just in case.. */
360 } /* next stackinfo */
361
362 PerlIO_printf(Perl_debug_log, "\n");
363 #else
364 PERL_UNUSED_CONTEXT;
365 #endif /* DEBUGGING */
366 }
367
368 /*
369 * ex: set ts=8 sts=4 sw=4 et:
370 */
371