3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Didst thou think that the eyes of the White Tower were blind? Nay, I
12 * have seen more than thou knowest, Gray Fool." --Denethor
19 #if defined(PERL_IMPLICIT_CONTEXT)
21 Perl_deb_nocontext(const char *pat, ...)
29 #endif /* DEBUGGING */
34 Perl_deb(pTHX_ const char *pat, ...)
41 #endif /* DEBUGGING */
45 Perl_vdeb(pTHX_ const char *pat, va_list *args)
48 char* file = OutCopFILE(PL_curcop);
50 #ifdef USE_5005THREADS
51 PerlIO_printf(Perl_debug_log, "0x%"UVxf" (%s:%ld)\t",
53 (file ? file : "<free>"),
54 (long)CopLINE(PL_curcop));
56 PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
57 (long)CopLINE(PL_curcop));
58 #endif /* USE_5005THREADS */
59 (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
60 #endif /* DEBUGGING */
64 Perl_debstackptrs(pTHX)
67 PerlIO_printf(Perl_debug_log,
68 "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
69 PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
70 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
71 (IV)(PL_stack_max-PL_stack_base));
72 PerlIO_printf(Perl_debug_log,
73 "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
74 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
75 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
76 PTR2UV(AvMAX(PL_curstack)));
77 #endif /* DEBUGGING */
82 /* dump the contents of a particular stack
83 * Display stack_base[stack_min+1 .. stack_max],
84 * and display the marks whose offsets are contained in addresses
85 * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
86 * of the stack values being displayed
88 * Only displays top 30 max
92 S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
93 I32 mark_min, I32 mark_max)
96 register I32 i = stack_max - 30;
97 I32 *markscan = PL_markstack + mark_min;
101 while (++markscan <= PL_markstack + mark_max)
106 PerlIO_printf(Perl_debug_log, "... ");
108 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
109 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
112 if (markscan <= PL_markstack + mark_max && *markscan < i) {
115 PerlIO_putc(Perl_debug_log, '*');
117 while (markscan <= PL_markstack + mark_max && *markscan < i);
118 PerlIO_printf(Perl_debug_log, " ");
122 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
125 PerlIO_printf(Perl_debug_log, "\n");
126 #endif /* DEBUGGING */
130 /* dump the current stack */
135 #ifndef SKIP_DEBUGGING
136 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
139 PerlIO_printf(Perl_debug_log, " => ");
140 deb_stack_n(PL_stack_base,
142 PL_stack_sp - PL_stack_base,
143 PL_curstackinfo->si_markoff,
144 PL_markstack_ptr - PL_markstack);
147 #endif /* SKIP_DEBUGGING */
153 static char * si_names[] = {
168 /* display all stacks */
172 Perl_deb_stack_all(pTHX)
179 /* rewind to start of chain */
180 si = PL_curstackinfo;
188 int si_name_ix = si->si_type+1; /* -1 is a valid index */
189 if (si_name_ix>= sizeof(si_names))
192 si_name = si_names[si_name_ix];
193 PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
196 for (ix=0; ix<=si->si_cxix; ix++) {
198 cx = &(si->si_cxstack[ix]);
199 PerlIO_printf(Perl_debug_log,
200 " CX %"IVdf": %-6s => ",
201 (IV)ix, PL_block_type[CxTYPE(cx)]
203 /* substitution contexts don't save stack pointers etc) */
204 if (CxTYPE(cx) == CXt_SUBST)
205 PerlIO_printf(Perl_debug_log, "\n");
208 /* Find the the current context's stack range by searching
209 * forward for any higher contexts using this stack; failing
210 * that, it will be equal to the size of the stack for old
211 * stacks, or PL_stack_sp for the current stack
214 I32 i, stack_min, stack_max, mark_min, mark_max;
215 I32 ret_min, ret_max;
219 cx_n = Null(PERL_CONTEXT*);
221 /* there's a separate stack per SI, so only search
224 for (i=ix+1; i<=si->si_cxix; i++) {
225 if (CxTYPE(cx) == CXt_SUBST)
227 cx_n = &(si->si_cxstack[i]);
231 stack_min = cx->blk_oldsp;
234 stack_max = cx_n->blk_oldsp;
236 else if (si == PL_curstackinfo) {
237 stack_max = PL_stack_sp - AvARRAY(si->si_stack);
240 stack_max = AvFILLp(si->si_stack);
243 /* for the other stack types, there's only one stack
244 * shared between all SIs */
248 cx_n = Null(PERL_CONTEXT*);
251 if (i > si_n->si_cxix) {
252 if (si_n == PL_curstackinfo)
255 si_n = si_n->si_next;
259 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
261 cx_n = &(si_n->si_cxstack[i]);
265 mark_min = cx->blk_oldmarksp;
266 ret_min = cx->blk_oldretsp;
268 mark_max = cx_n->blk_oldmarksp;
269 ret_max = cx_n->blk_oldretsp;
272 mark_max = PL_markstack_ptr - PL_markstack;
273 ret_max = PL_retstack_ix;
276 deb_stack_n(AvARRAY(si->si_stack),
277 stack_min, stack_max, mark_min, mark_max);
279 if (ret_max > ret_min) {
280 PerlIO_printf(Perl_debug_log, " retop=%s\n",
282 ? OP_NAME(PL_retstack[ret_min])
291 if (si == PL_curstackinfo)
296 break; /* shouldn't happen, but just in case.. */
297 } /* next stackinfo */
299 PerlIO_printf(Perl_debug_log, "\n");
300 #endif /* DEBUGGING */