Commit | Line | Data |
---|---|---|
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) |
28 | void | |
29 | Perl_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 | 44 | void |
864dbfa3 | 45 | Perl_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 | ||
58 | void | |
59 | Perl_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 | 81 | I32 |
864dbfa3 | 82 | Perl_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 |
111 | STATIC void |
112 | S_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 | ||
162 | I32 | |
163 | Perl_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 | 183 | static 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 | ||
202 | void | |
203 | Perl_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 | */ |