Porting/makerel: handle more sha1 variants,
[p5sagit/p5-mst-13.2.git] / deb.c
CommitLineData
a0d0e21e 1/* deb.c
79072805 2 *
1129b882 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 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 9 */
10
11/*
4ac71550 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 16 */
17
166f8a29 18/*
61296642 19 * This file contains various utilities for producing debugging output
20 * (mainly related to displaying the stack)
166f8a29 21 */
22
79072805 23#include "EXTERN.h"
864dbfa3 24#define PERL_IN_DEB_C
79072805 25#include "perl.h"
26
c5be433b 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 35 va_start(args, pat);
36 vdeb(pat, &args);
37 va_end(args);
5f66b61c 38#else
39 PERL_UNUSED_ARG(pat);
c5be433b 40#endif /* DEBUGGING */
41}
42#endif
43
8990e307 44void
864dbfa3 45Perl_deb(pTHX_ const char *pat, ...)
79072805 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 56}
57
58void
59Perl_vdeb(pTHX_ const char *pat, va_list *args)
60{
61#ifdef DEBUGGING
97aff369 62 dVAR;
185c8bac 63 const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
64 const char* const display_file = file ? file : "<free>";
65 const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0;
79072805 66
7918f24d 67 PERL_ARGS_ASSERT_VDEB;
68
185c8bac 69 if (DEBUG_v_TEST)
70 PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
71 (long)PerlProc_getpid(), display_file, line);
72 else
73 PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
c5be433b 74 (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
65e66c80 75#else
96a5add6 76 PERL_UNUSED_CONTEXT;
65e66c80 77 PERL_UNUSED_ARG(pat);
78 PERL_UNUSED_ARG(args);
17c3b450 79#endif /* DEBUGGING */
79072805 80}
79072805 81
79072805 82I32
864dbfa3 83Perl_debstackptrs(pTHX)
79072805 84{
17c3b450 85#ifdef DEBUGGING
97aff369 86 dVAR;
b900a521 87 PerlIO_printf(Perl_debug_log,
88 "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
89 PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
90 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
91 (IV)(PL_stack_max-PL_stack_base));
92 PerlIO_printf(Perl_debug_log,
93 "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
94 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
95 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
96 PTR2UV(AvMAX(PL_curstack)));
17c3b450 97#endif /* DEBUGGING */
79072805 98 return 0;
99}
100
a0d0e21e 101
d6721266 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 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
97aff369 116 dVAR;
d6721266 117 register I32 i = stack_max - 30;
b64e5050 118 const I32 *markscan = PL_markstack + mark_min;
7918f24d 119
120 PERL_ARGS_ASSERT_DEB_STACK_N;
121
d6721266 122 if (i < stack_min)
123 i = stack_min;
a0d0e21e 124
d6721266 125 while (++markscan <= PL_markstack + mark_max)
a0d0e21e 126 if (*markscan >= i)
127 break;
79072805 128
d6721266 129 if (i > stack_min)
130 PerlIO_printf(Perl_debug_log, "... ");
131
132 if (stack_base[0] != &PL_sv_undef || stack_max < 0)
760ac839 133 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
a0d0e21e 134 do {
135 ++i;
d6721266 136 if (markscan <= PL_markstack + mark_max && *markscan < i) {
a0d0e21e 137 do {
138 ++markscan;
760ac839 139 PerlIO_putc(Perl_debug_log, '*');
a0d0e21e 140 }
d6721266 141 while (markscan <= PL_markstack + mark_max && *markscan < i);
760ac839 142 PerlIO_printf(Perl_debug_log, " ");
79072805 143 }
d6721266 144 if (i > stack_max)
a0d0e21e 145 break;
d6721266 146 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
79072805 147 }
a0d0e21e 148 while (1);
760ac839 149 PerlIO_printf(Perl_debug_log, "\n");
65e66c80 150#else
96a5add6 151 PERL_UNUSED_CONTEXT;
65e66c80 152 PERL_UNUSED_ARG(stack_base);
153 PERL_UNUSED_ARG(stack_min);
154 PERL_UNUSED_ARG(stack_max);
155 PERL_UNUSED_ARG(mark_min);
156 PERL_UNUSED_ARG(mark_max);
d6721266 157#endif /* DEBUGGING */
158}
159
160
161/* dump the current stack */
162
163I32
164Perl_debstack(pTHX)
165{
166#ifndef SKIP_DEBUGGING
97aff369 167 dVAR;
d6721266 168 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
169 return 0;
170
171 PerlIO_printf(Perl_debug_log, " => ");
172 deb_stack_n(PL_stack_base,
173 0,
174 PL_stack_sp - PL_stack_base,
175 PL_curstackinfo->si_markoff,
176 PL_markstack_ptr - PL_markstack);
177
178
1045810a 179#endif /* SKIP_DEBUGGING */
79072805 180 return 0;
181}
d6721266 182
183
184#ifdef DEBUGGING
0bd48802 185static const char * const si_names[] = {
d6721266 186 "UNKNOWN",
187 "UNDEF",
188 "MAIN",
189 "MAGIC",
190 "SORT",
191 "SIGNAL",
192 "OVERLOAD",
193 "DESTROY",
194 "WARNHOOK",
195 "DIEHOOK",
196 "REQUIRE"
197};
198#endif
199
200/* display all stacks */
201
202
203void
204Perl_deb_stack_all(pTHX)
205{
206#ifdef DEBUGGING
97aff369 207 dVAR;
0bd48802 208 I32 si_ix;
7452cf6a 209 const PERL_SI *si;
d6721266 210
211 /* rewind to start of chain */
212 si = PL_curstackinfo;
213 while (si->si_prev)
214 si = si->si_prev;
215
216 si_ix=0;
217 for (;;)
218 {
bb7a0f54 219 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
666ea192 220 const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix];
0bd48802 221 I32 ix;
d6721266 222 PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
e922992d 223 (IV)si_ix, si_name);
d6721266 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,
229 " CX %"IVdf": %-6s => ",
f1fe7cd8 230 (IV)ix, PL_block_type[CxTYPE(cx)]
d6721266 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 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;
4608196e 244 const PERL_CONTEXT *cx_n = NULL;
7452cf6a 245 const PERL_SI *si_n;
d6721266 246
d6721266 247 /* there's a separate stack per SI, so only search
248 * this one */
249
250 for (i=ix+1; i<=si->si_cxix; i++) {
251 if (CxTYPE(cx) == CXt_SUBST)
252 continue;
253 cx_n = &(si->si_cxstack[i]);
254 break;
255 }
256
257 stack_min = cx->blk_oldsp;
258
259 if (cx_n) {
260 stack_max = cx_n->blk_oldsp;
261 }
262 else if (si == PL_curstackinfo) {
263 stack_max = PL_stack_sp - AvARRAY(si->si_stack);
264 }
265 else {
266 stack_max = AvFILLp(si->si_stack);
267 }
268
269 /* for the other stack types, there's only one stack
270 * shared between all SIs */
271
272 si_n = si;
273 i = ix;
4608196e 274 cx_n = NULL;
d6721266 275 for (;;) {
276 i++;
277 if (i > si_n->si_cxix) {
278 if (si_n == PL_curstackinfo)
279 break;
280 else {
281 si_n = si_n->si_next;
282 i = 0;
283 }
284 }
285 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
286 continue;
287 cx_n = &(si_n->si_cxstack[i]);
288 break;
289 }
290
291 mark_min = cx->blk_oldmarksp;
d6721266 292 if (cx_n) {
293 mark_max = cx_n->blk_oldmarksp;
d6721266 294 }
295 else {
296 mark_max = PL_markstack_ptr - PL_markstack;
d6721266 297 }
298
299 deb_stack_n(AvARRAY(si->si_stack),
300 stack_min, stack_max, mark_min, mark_max);
301
f39bc417 302 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
303 || CxTYPE(cx) == CXt_FORMAT)
304 {
8e663997 305 const OP * const retop = cx->blk_sub.retop;
f39bc417 306
d6721266 307 PerlIO_printf(Perl_debug_log, " retop=%s\n",
f39bc417 308 retop ? OP_NAME(retop) : "(null)"
d6721266 309 );
310 }
d6721266 311 }
312 } /* next context */
313
314
315 if (si == PL_curstackinfo)
316 break;
317 si = si->si_next;
318 si_ix++;
319 if (!si)
320 break; /* shouldn't happen, but just in case.. */
321 } /* next stackinfo */
322
323 PerlIO_printf(Perl_debug_log, "\n");
96a5add6 324#else
325 PERL_UNUSED_CONTEXT;
d6721266 326#endif /* DEBUGGING */
327}
328
66610fdd 329/*
330 * Local variables:
331 * c-indentation-style: bsd
332 * c-basic-offset: 4
333 * indent-tabs-mode: t
334 * End:
335 *
37442d52 336 * ex: set ts=8 sts=4 sw=4 noet:
337 */