This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typo in the description of change 27911
[perl5.git] / deb.c
CommitLineData
a0d0e21e 1/* deb.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999,
54ca4ee7 4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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/*
12 * "Didst thou think that the eyes of the White Tower were blind? Nay, I
13 * have seen more than thou knowest, Gray Fool." --Denethor
79072805
LW
14 */
15
166f8a29 16/*
61296642
DM
17 * This file contains various utilities for producing debugging output
18 * (mainly related to displaying the stack)
166f8a29
DM
19 */
20
79072805 21#include "EXTERN.h"
864dbfa3 22#define PERL_IN_DEB_C
79072805
LW
23#include "perl.h"
24
c5be433b
GS
25#if defined(PERL_IMPLICIT_CONTEXT)
26void
27Perl_deb_nocontext(const char *pat, ...)
28{
29#ifdef DEBUGGING
30 dTHX;
31 va_list args;
32 va_start(args, pat);
33 vdeb(pat, &args);
34 va_end(args);
5f66b61c
AL
35#else
36 PERL_UNUSED_ARG(pat);
c5be433b
GS
37#endif /* DEBUGGING */
38}
39#endif
40
8990e307 41void
864dbfa3 42Perl_deb(pTHX_ const char *pat, ...)
79072805 43{
17c3b450 44#ifdef DEBUGGING
79072805 45 va_list args;
c5be433b
GS
46 va_start(args, pat);
47 vdeb(pat, &args);
48 va_end(args);
65e66c80 49#else
96a5add6 50 PERL_UNUSED_CONTEXT;
65e66c80 51 PERL_UNUSED_ARG(pat);
c5be433b
GS
52#endif /* DEBUGGING */
53}
54
55void
56Perl_vdeb(pTHX_ const char *pat, va_list *args)
57{
58#ifdef DEBUGGING
97aff369 59 dVAR;
5f66b61c 60 const char* const file = OutCopFILE(PL_curcop);
79072805 61
cc49e20b
GS
62 PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
63 (long)CopLINE(PL_curcop));
c5be433b 64 (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
65e66c80 65#else
96a5add6 66 PERL_UNUSED_CONTEXT;
65e66c80
SP
67 PERL_UNUSED_ARG(pat);
68 PERL_UNUSED_ARG(args);
17c3b450 69#endif /* DEBUGGING */
79072805 70}
79072805 71
79072805 72I32
864dbfa3 73Perl_debstackptrs(pTHX)
79072805 74{
17c3b450 75#ifdef DEBUGGING
97aff369 76 dVAR;
b900a521
JH
77 PerlIO_printf(Perl_debug_log,
78 "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
79 PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
80 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
81 (IV)(PL_stack_max-PL_stack_base));
82 PerlIO_printf(Perl_debug_log,
83 "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
84 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
85 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
86 PTR2UV(AvMAX(PL_curstack)));
17c3b450 87#endif /* DEBUGGING */
79072805
LW
88 return 0;
89}
90
a0d0e21e 91
d6721266
DM
92/* dump the contents of a particular stack
93 * Display stack_base[stack_min+1 .. stack_max],
94 * and display the marks whose offsets are contained in addresses
95 * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
96 * of the stack values being displayed
97 *
98 * Only displays top 30 max
99 */
1045810a 100
d6721266
DM
101STATIC void
102S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
103 I32 mark_min, I32 mark_max)
104{
105#ifdef DEBUGGING
97aff369 106 dVAR;
d6721266 107 register I32 i = stack_max - 30;
b64e5050 108 const I32 *markscan = PL_markstack + mark_min;
d6721266
DM
109 if (i < stack_min)
110 i = stack_min;
a0d0e21e 111
d6721266 112 while (++markscan <= PL_markstack + mark_max)
a0d0e21e
LW
113 if (*markscan >= i)
114 break;
79072805 115
d6721266
DM
116 if (i > stack_min)
117 PerlIO_printf(Perl_debug_log, "... ");
118
119 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
760ac839 120 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
a0d0e21e
LW
121 do {
122 ++i;
d6721266 123 if (markscan <= PL_markstack + mark_max && *markscan < i) {
a0d0e21e
LW
124 do {
125 ++markscan;
760ac839 126 PerlIO_putc(Perl_debug_log, '*');
a0d0e21e 127 }
d6721266 128 while (markscan <= PL_markstack + mark_max && *markscan < i);
760ac839 129 PerlIO_printf(Perl_debug_log, " ");
79072805 130 }
d6721266 131 if (i > stack_max)
a0d0e21e 132 break;
d6721266 133 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
79072805 134 }
a0d0e21e 135 while (1);
760ac839 136 PerlIO_printf(Perl_debug_log, "\n");
65e66c80 137#else
96a5add6 138 PERL_UNUSED_CONTEXT;
65e66c80
SP
139 PERL_UNUSED_ARG(stack_base);
140 PERL_UNUSED_ARG(stack_min);
141 PERL_UNUSED_ARG(stack_max);
142 PERL_UNUSED_ARG(mark_min);
143 PERL_UNUSED_ARG(mark_max);
d6721266
DM
144#endif /* DEBUGGING */
145}
146
147
148/* dump the current stack */
149
150I32
151Perl_debstack(pTHX)
152{
153#ifndef SKIP_DEBUGGING
97aff369 154 dVAR;
d6721266
DM
155 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
156 return 0;
157
158 PerlIO_printf(Perl_debug_log, " => ");
159 deb_stack_n(PL_stack_base,
160 0,
161 PL_stack_sp - PL_stack_base,
162 PL_curstackinfo->si_markoff,
163 PL_markstack_ptr - PL_markstack);
164
165
1045810a 166#endif /* SKIP_DEBUGGING */
79072805
LW
167 return 0;
168}
d6721266
DM
169
170
171#ifdef DEBUGGING
0bd48802 172static const char * const si_names[] = {
d6721266
DM
173 "UNKNOWN",
174 "UNDEF",
175 "MAIN",
176 "MAGIC",
177 "SORT",
178 "SIGNAL",
179 "OVERLOAD",
180 "DESTROY",
181 "WARNHOOK",
182 "DIEHOOK",
183 "REQUIRE"
184};
185#endif
186
187/* display all stacks */
188
189
190void
191Perl_deb_stack_all(pTHX)
192{
193#ifdef DEBUGGING
97aff369 194 dVAR;
0bd48802 195 I32 si_ix;
7452cf6a 196 const PERL_SI *si;
d6721266
DM
197
198 /* rewind to start of chain */
199 si = PL_curstackinfo;
200 while (si->si_prev)
201 si = si->si_prev;
202
203 si_ix=0;
204 for (;;)
205 {
bb7a0f54 206 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
666ea192 207 const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix];
0bd48802 208 I32 ix;
d6721266 209 PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
e922992d 210 (IV)si_ix, si_name);
d6721266
DM
211
212 for (ix=0; ix<=si->si_cxix; ix++) {
213
7452cf6a 214 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
d6721266
DM
215 PerlIO_printf(Perl_debug_log,
216 " CX %"IVdf": %-6s => ",
f1fe7cd8 217 (IV)ix, PL_block_type[CxTYPE(cx)]
d6721266
DM
218 );
219 /* substitution contexts don't save stack pointers etc) */
220 if (CxTYPE(cx) == CXt_SUBST)
221 PerlIO_printf(Perl_debug_log, "\n");
222 else {
223
224 /* Find the the current context's stack range by searching
225 * forward for any higher contexts using this stack; failing
226 * that, it will be equal to the size of the stack for old
227 * stacks, or PL_stack_sp for the current stack
228 */
229
230 I32 i, stack_min, stack_max, mark_min, mark_max;
4608196e 231 const PERL_CONTEXT *cx_n = NULL;
7452cf6a 232 const PERL_SI *si_n;
d6721266 233
d6721266
DM
234 /* there's a separate stack per SI, so only search
235 * this one */
236
237 for (i=ix+1; i<=si->si_cxix; i++) {
238 if (CxTYPE(cx) == CXt_SUBST)
239 continue;
240 cx_n = &(si->si_cxstack[i]);
241 break;
242 }
243
244 stack_min = cx->blk_oldsp;
245
246 if (cx_n) {
247 stack_max = cx_n->blk_oldsp;
248 }
249 else if (si == PL_curstackinfo) {
250 stack_max = PL_stack_sp - AvARRAY(si->si_stack);
251 }
252 else {
253 stack_max = AvFILLp(si->si_stack);
254 }
255
256 /* for the other stack types, there's only one stack
257 * shared between all SIs */
258
259 si_n = si;
260 i = ix;
4608196e 261 cx_n = NULL;
d6721266
DM
262 for (;;) {
263 i++;
264 if (i > si_n->si_cxix) {
265 if (si_n == PL_curstackinfo)
266 break;
267 else {
268 si_n = si_n->si_next;
269 i = 0;
270 }
271 }
272 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
273 continue;
274 cx_n = &(si_n->si_cxstack[i]);
275 break;
276 }
277
278 mark_min = cx->blk_oldmarksp;
d6721266
DM
279 if (cx_n) {
280 mark_max = cx_n->blk_oldmarksp;
d6721266
DM
281 }
282 else {
283 mark_max = PL_markstack_ptr - PL_markstack;
d6721266
DM
284 }
285
286 deb_stack_n(AvARRAY(si->si_stack),
287 stack_min, stack_max, mark_min, mark_max);
288
f39bc417
DM
289 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
290 || CxTYPE(cx) == CXt_FORMAT)
291 {
7452cf6a 292 const OP * const retop = (CxTYPE(cx) == CXt_EVAL)
f39bc417
DM
293 ? cx->blk_eval.retop : cx->blk_sub.retop;
294
d6721266 295 PerlIO_printf(Perl_debug_log, " retop=%s\n",
f39bc417 296 retop ? OP_NAME(retop) : "(null)"
d6721266
DM
297 );
298 }
d6721266
DM
299 }
300 } /* next context */
301
302
303 if (si == PL_curstackinfo)
304 break;
305 si = si->si_next;
306 si_ix++;
307 if (!si)
308 break; /* shouldn't happen, but just in case.. */
309 } /* next stackinfo */
310
311 PerlIO_printf(Perl_debug_log, "\n");
96a5add6
AL
312#else
313 PERL_UNUSED_CONTEXT;
d6721266
DM
314#endif /* DEBUGGING */
315}
316
66610fdd
RGS
317/*
318 * Local variables:
319 * c-indentation-style: bsd
320 * c-basic-offset: 4
321 * indent-tabs-mode: t
322 * End:
323 *
37442d52
RGS
324 * ex: set ts=8 sts=4 sw=4 noet:
325 */