This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Import perl5321delta.pod
[perl5.git] / deb.c
CommitLineData
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
c5be433b
GS
27#if defined(PERL_IMPLICIT_CONTEXT)
28void
29Perl_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
8990e307 44void
864dbfa3 45Perl_deb(pTHX_ const char *pat, ...)
79072805
LW
46{
47 va_list args;
7918f24d 48 PERL_ARGS_ASSERT_DEB;
c5be433b 49 va_start(args, pat);
fe5bfecd 50#ifdef DEBUGGING
c5be433b 51 vdeb(pat, &args);
65e66c80 52#else
96a5add6 53 PERL_UNUSED_CONTEXT;
c5be433b 54#endif /* DEBUGGING */
fe5bfecd 55 va_end(args);
c5be433b
GS
56}
57
58void
59Perl_vdeb(pTHX_ const char *pat, va_list *args)
60{
61#ifdef DEBUGGING
185c8bac
NC
62 const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
63 const char* const display_file = file ? file : "<free>";
64 const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0;
79072805 65
7918f24d
NC
66 PERL_ARGS_ASSERT_VDEB;
67
185c8bac 68 if (DEBUG_v_TEST)
1604cfb0
MS
69 PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
70 (long)PerlProc_getpid(), display_file, line);
185c8bac 71 else
1604cfb0 72 PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
c5be433b 73 (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
65e66c80 74#else
96a5add6 75 PERL_UNUSED_CONTEXT;
65e66c80
SP
76 PERL_UNUSED_ARG(pat);
77 PERL_UNUSED_ARG(args);
17c3b450 78#endif /* DEBUGGING */
79072805 79}
79072805 80
79072805 81I32
864dbfa3 82Perl_debstackptrs(pTHX)
79072805 83{
17c3b450 84#ifdef DEBUGGING
b900a521 85 PerlIO_printf(Perl_debug_log,
1604cfb0
MS
86 "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n",
87 PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
88 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
89 (IV)(PL_stack_max-PL_stack_base));
b900a521 90 PerlIO_printf(Perl_debug_log,
1604cfb0
MS
91 "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n",
92 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
93 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
94 PTR2UV(AvMAX(PL_curstack)));
81611534
JH
95#else
96 PERL_UNUSED_CONTEXT;
17c3b450 97#endif /* DEBUGGING */
79072805
LW
98 return 0;
99}
100
a0d0e21e 101
d6721266
DM
102/* dump the contents of a particular stack
103 * Display stack_base[stack_min+1 .. stack_max],
104 * and display the marks whose offsets are contained in addresses
105 * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
106 * of the stack values being displayed
107 *
108 * Only displays top 30 max
109 */
1045810a 110
d6721266
DM
111STATIC void
112S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
1604cfb0 113 I32 mark_min, I32 mark_max)
d6721266
DM
114{
115#ifdef DEBUGGING
eb578fdb 116 I32 i = stack_max - 30;
b64e5050 117 const I32 *markscan = PL_markstack + mark_min;
7918f24d
NC
118
119 PERL_ARGS_ASSERT_DEB_STACK_N;
120
d6721266 121 if (i < stack_min)
1604cfb0 122 i = stack_min;
a0d0e21e 123
d6721266 124 while (++markscan <= PL_markstack + mark_max)
1604cfb0
MS
125 if (*markscan >= i)
126 break;
79072805 127
d6721266 128 if (i > stack_min)
1604cfb0 129 PerlIO_printf(Perl_debug_log, "... ");
d6721266
DM
130
131 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
1604cfb0 132 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
a0d0e21e 133 do {
1604cfb0
MS
134 ++i;
135 if (markscan <= PL_markstack + mark_max && *markscan < i) {
136 do {
137 ++markscan;
138 (void)PerlIO_putc(Perl_debug_log, '*');
139 }
140 while (markscan <= PL_markstack + mark_max && *markscan < i);
141 PerlIO_printf(Perl_debug_log, " ");
142 }
143 if (i > stack_max)
144 break;
145 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
79072805 146 }
a0d0e21e 147 while (1);
760ac839 148 PerlIO_printf(Perl_debug_log, "\n");
65e66c80 149#else
96a5add6 150 PERL_UNUSED_CONTEXT;
65e66c80
SP
151 PERL_UNUSED_ARG(stack_base);
152 PERL_UNUSED_ARG(stack_min);
153 PERL_UNUSED_ARG(stack_max);
154 PERL_UNUSED_ARG(mark_min);
155 PERL_UNUSED_ARG(mark_max);
d6721266
DM
156#endif /* DEBUGGING */
157}
158
159
160/* dump the current stack */
161
162I32
163Perl_debstack(pTHX)
164{
165#ifndef SKIP_DEBUGGING
166 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
1604cfb0 167 return 0;
d6721266
DM
168
169 PerlIO_printf(Perl_debug_log, " => ");
170 deb_stack_n(PL_stack_base,
1604cfb0
MS
171 0,
172 PL_stack_sp - PL_stack_base,
173 PL_curstackinfo->si_markoff,
174 PL_markstack_ptr - PL_markstack);
d6721266
DM
175
176
1045810a 177#endif /* SKIP_DEBUGGING */
79072805
LW
178 return 0;
179}
d6721266
DM
180
181
182#ifdef DEBUGGING
0bd48802 183static const char * const si_names[] = {
d6721266
DM
184 "UNKNOWN",
185 "UNDEF",
186 "MAIN",
187 "MAGIC",
188 "SORT",
189 "SIGNAL",
190 "OVERLOAD",
191 "DESTROY",
192 "WARNHOOK",
193 "DIEHOOK",
00898ccb 194 "REQUIRE",
e1a10f35 195 "MULTICALL"
d6721266
DM
196};
197#endif
198
199/* display all stacks */
200
201
202void
203Perl_deb_stack_all(pTHX)
204{
205#ifdef DEBUGGING
0bd48802 206 I32 si_ix;
7452cf6a 207 const PERL_SI *si;
d6721266
DM
208
209 /* rewind to start of chain */
210 si = PL_curstackinfo;
211 while (si->si_prev)
1604cfb0 212 si = si->si_prev;
d6721266
DM
213
214 si_ix=0;
215 for (;;)
216 {
bb7a0f54 217 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
00b25eff
JH
218 const char * const si_name =
219 si_name_ix < C_ARRAY_LENGTH(si_names) ?
220 si_names[si_name_ix] : "????";
1604cfb0
MS
221 I32 ix;
222 PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n",
223 (IV)si_ix, si_name);
224
225 for (ix=0; ix<=si->si_cxix; ix++) {
226
227 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
228 PerlIO_printf(Perl_debug_log,
229 " CX %" IVdf ": %-6s => ",
230 (IV)ix, PL_block_type[CxTYPE(cx)]
231 );
232 /* substitution contexts don't save stack pointers etc) */
233 if (CxTYPE(cx) == CXt_SUBST)
234 PerlIO_printf(Perl_debug_log, "\n");
235 else {
236
237 /* Find the current context's stack range by searching
238 * forward for any higher contexts using this stack; failing
239 * that, it will be equal to the size of the stack for old
240 * stacks, or PL_stack_sp for the current stack
241 */
242
243 I32 i, stack_min, stack_max, mark_min, mark_max;
244 const PERL_CONTEXT *cx_n = NULL;
245 const PERL_SI *si_n;
d6721266 246
5ef71089
DM
247 /* there's a separate argument stack per SI, so only
248 * search this one */
d6721266 249
1604cfb0 250 for (i=ix+1; i<=si->si_cxix; i++) {
5ef71089
DM
251 const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]);
252 if (CxTYPE(this_cx) == CXt_SUBST)
1604cfb0
MS
253 continue;
254 cx_n = this_cx;
255 break;
256 }
257
258 stack_min = cx->blk_oldsp;
259
260 if (cx_n) {
261 stack_max = cx_n->blk_oldsp;
262 }
263 else if (si == PL_curstackinfo) {
264 stack_max = PL_stack_sp - AvARRAY(si->si_stack);
265 }
266 else {
267 stack_max = AvFILLp(si->si_stack);
268 }
d6721266 269
5ef71089
DM
270 /* for the markstack, there's only one stack shared
271 * between all SIs */
d6721266 272
1604cfb0
MS
273 si_n = si;
274 i = ix;
275 cx_n = NULL;
276 for (;;) {
277 i++;
278 if (i > si_n->si_cxix) {
279 if (si_n == PL_curstackinfo)
280 break;
281 else {
282 si_n = si_n->si_next;
283 i = 0;
284 }
285 }
286 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
287 continue;
288 cx_n = &(si_n->si_cxstack[i]);
289 break;
290 }
291
292 mark_min = cx->blk_oldmarksp;
293 if (cx_n) {
294 mark_max = cx_n->blk_oldmarksp;
295 }
296 else {
297 mark_max = PL_markstack_ptr - PL_markstack;
298 }
299
300 deb_stack_n(AvARRAY(si->si_stack),
301 stack_min, stack_max, mark_min, mark_max);
302
303 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
304 || CxTYPE(cx) == CXt_FORMAT)
305 {
306 const OP * const retop = cx->blk_sub.retop;
307
308 PerlIO_printf(Perl_debug_log, " retop=%s\n",
309 retop ? OP_NAME(retop) : "(null)"
310 );
311 }
312 }
313 } /* next context */
314
315
316 if (si == PL_curstackinfo)
317 break;
318 si = si->si_next;
319 si_ix++;
320 if (!si)
321 break; /* shouldn't happen, but just in case.. */
d6721266
DM
322 } /* next stackinfo */
323
324 PerlIO_printf(Perl_debug_log, "\n");
96a5add6
AL
325#else
326 PERL_UNUSED_CONTEXT;
d6721266
DM
327#endif /* DEBUGGING */
328}
329
66610fdd 330/*
14d04a33 331 * ex: set ts=8 sts=4 sw=4 et:
37442d52 332 */