This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Various updates and fixes to some of the SysV IPC ops and their tests
[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
NC
68 if (DEBUG_v_TEST)
69 PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
70 (long)PerlProc_getpid(), display_file, line);
71 else
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,
147e3846 86 "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n",
b900a521
JH
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));
90 PerlIO_printf(Perl_debug_log,
147e3846 91 "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n",
b900a521
JH
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,
113 I32 mark_min, I32 mark_max)
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
DM
121 if (i < stack_min)
122 i = stack_min;
a0d0e21e 123
d6721266 124 while (++markscan <= PL_markstack + mark_max)
a0d0e21e
LW
125 if (*markscan >= i)
126 break;
79072805 127
d6721266
DM
128 if (i > stack_min)
129 PerlIO_printf(Perl_debug_log, "... ");
130
131 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
760ac839 132 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
a0d0e21e
LW
133 do {
134 ++i;
d6721266 135 if (markscan <= PL_markstack + mark_max && *markscan < i) {
a0d0e21e
LW
136 do {
137 ++markscan;
38d7fd8b 138 (void)PerlIO_putc(Perl_debug_log, '*');
a0d0e21e 139 }
d6721266 140 while (markscan <= PL_markstack + mark_max && *markscan < i);
760ac839 141 PerlIO_printf(Perl_debug_log, " ");
79072805 142 }
d6721266 143 if (i > stack_max)
a0d0e21e 144 break;
d6721266 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_)
167 return 0;
168
169 PerlIO_printf(Perl_debug_log, " => ");
170 deb_stack_n(PL_stack_base,
171 0,
172 PL_stack_sp - PL_stack_base,
173 PL_curstackinfo->si_markoff,
174 PL_markstack_ptr - PL_markstack);
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)
212 si = si->si_prev;
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] : "????";
0bd48802 221 I32 ix;
147e3846 222 PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n",
e922992d 223 (IV)si_ix, si_name);
d6721266
DM
224
225 for (ix=0; ix<=si->si_cxix; ix++) {
226
7452cf6a 227 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
d6721266 228 PerlIO_printf(Perl_debug_log,
147e3846 229 " CX %" IVdf ": %-6s => ",
f1fe7cd8 230 (IV)ix, PL_block_type[CxTYPE(cx)]
d6721266
DM
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
5ef71089 237 /* Find the current context's stack range by searching
d6721266
DM
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;
4608196e 244 const PERL_CONTEXT *cx_n = NULL;
7452cf6a 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
DM
249
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)
d6721266 253 continue;
5ef71089 254 cx_n = this_cx;
d6721266
DM
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 }
269
5ef71089
DM
270 /* for the markstack, there's only one stack shared
271 * between all SIs */
d6721266
DM
272
273 si_n = si;
274 i = ix;
4608196e 275 cx_n = NULL;
d6721266
DM
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;
d6721266
DM
293 if (cx_n) {
294 mark_max = cx_n->blk_oldmarksp;
d6721266
DM
295 }
296 else {
297 mark_max = PL_markstack_ptr - PL_markstack;
d6721266
DM
298 }
299
300 deb_stack_n(AvARRAY(si->si_stack),
301 stack_min, stack_max, mark_min, mark_max);
302
f39bc417
DM
303 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
304 || CxTYPE(cx) == CXt_FORMAT)
305 {
8e663997 306 const OP * const retop = cx->blk_sub.retop;
f39bc417 307
d6721266 308 PerlIO_printf(Perl_debug_log, " retop=%s\n",
f39bc417 309 retop ? OP_NAME(retop) : "(null)"
d6721266
DM
310 );
311 }
d6721266
DM
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.. */
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 */