Commit | Line | Data |
---|---|---|
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) |
26 | void | |
27 | Perl_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 | 41 | void |
864dbfa3 | 42 | Perl_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 | ||
55 | void | |
56 | Perl_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 | 72 | I32 |
864dbfa3 | 73 | Perl_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 |
101 | STATIC void |
102 | S_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 | ||
150 | I32 | |
151 | Perl_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 | 172 | static 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 | ||
190 | void | |
191 | Perl_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 MHM |
206 | const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ |
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 | */ |