Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | /* deb.c |
79072805 | 2 | * |
4bb101f2 JH |
3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, |
4 | * 2000, 2001, 2002, 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 | ||
16 | #include "EXTERN.h" | |
864dbfa3 | 17 | #define PERL_IN_DEB_C |
79072805 LW |
18 | #include "perl.h" |
19 | ||
c5be433b GS |
20 | #if defined(PERL_IMPLICIT_CONTEXT) |
21 | void | |
22 | Perl_deb_nocontext(const char *pat, ...) | |
23 | { | |
24 | #ifdef DEBUGGING | |
25 | dTHX; | |
26 | va_list args; | |
27 | va_start(args, pat); | |
28 | vdeb(pat, &args); | |
29 | va_end(args); | |
30 | #endif /* DEBUGGING */ | |
31 | } | |
32 | #endif | |
33 | ||
8990e307 | 34 | void |
864dbfa3 | 35 | Perl_deb(pTHX_ const char *pat, ...) |
79072805 | 36 | { |
17c3b450 | 37 | #ifdef DEBUGGING |
79072805 | 38 | va_list args; |
c5be433b GS |
39 | va_start(args, pat); |
40 | vdeb(pat, &args); | |
41 | va_end(args); | |
42 | #endif /* DEBUGGING */ | |
43 | } | |
44 | ||
45 | void | |
46 | Perl_vdeb(pTHX_ const char *pat, va_list *args) | |
47 | { | |
48 | #ifdef DEBUGGING | |
248c2a4d | 49 | char* file = OutCopFILE(PL_curcop); |
79072805 | 50 | |
cc49e20b GS |
51 | PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"), |
52 | (long)CopLINE(PL_curcop)); | |
c5be433b | 53 | (void) PerlIO_vprintf(Perl_debug_log, pat, *args); |
17c3b450 | 54 | #endif /* DEBUGGING */ |
79072805 | 55 | } |
79072805 | 56 | |
79072805 | 57 | I32 |
864dbfa3 | 58 | Perl_debstackptrs(pTHX) |
79072805 | 59 | { |
17c3b450 | 60 | #ifdef DEBUGGING |
b900a521 JH |
61 | PerlIO_printf(Perl_debug_log, |
62 | "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n", | |
63 | PTR2UV(PL_curstack), PTR2UV(PL_stack_base), | |
64 | (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), | |
65 | (IV)(PL_stack_max-PL_stack_base)); | |
66 | PerlIO_printf(Perl_debug_log, | |
67 | "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n", | |
68 | PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), | |
69 | PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), | |
70 | PTR2UV(AvMAX(PL_curstack))); | |
17c3b450 | 71 | #endif /* DEBUGGING */ |
79072805 LW |
72 | return 0; |
73 | } | |
74 | ||
a0d0e21e | 75 | |
d6721266 DM |
76 | /* dump the contents of a particular stack |
77 | * Display stack_base[stack_min+1 .. stack_max], | |
78 | * and display the marks whose offsets are contained in addresses | |
79 | * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range | |
80 | * of the stack values being displayed | |
81 | * | |
82 | * Only displays top 30 max | |
83 | */ | |
1045810a | 84 | |
d6721266 DM |
85 | STATIC void |
86 | S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, | |
87 | I32 mark_min, I32 mark_max) | |
88 | { | |
89 | #ifdef DEBUGGING | |
90 | register I32 i = stack_max - 30; | |
91 | I32 *markscan = PL_markstack + mark_min; | |
92 | if (i < stack_min) | |
93 | i = stack_min; | |
a0d0e21e | 94 | |
d6721266 | 95 | while (++markscan <= PL_markstack + mark_max) |
a0d0e21e LW |
96 | if (*markscan >= i) |
97 | break; | |
79072805 | 98 | |
d6721266 DM |
99 | if (i > stack_min) |
100 | PerlIO_printf(Perl_debug_log, "... "); | |
101 | ||
102 | if (stack_base[0] != &PL_sv_undef || stack_max < 0) | |
760ac839 | 103 | PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); |
a0d0e21e LW |
104 | do { |
105 | ++i; | |
d6721266 | 106 | if (markscan <= PL_markstack + mark_max && *markscan < i) { |
a0d0e21e LW |
107 | do { |
108 | ++markscan; | |
760ac839 | 109 | PerlIO_putc(Perl_debug_log, '*'); |
a0d0e21e | 110 | } |
d6721266 | 111 | while (markscan <= PL_markstack + mark_max && *markscan < i); |
760ac839 | 112 | PerlIO_printf(Perl_debug_log, " "); |
79072805 | 113 | } |
d6721266 | 114 | if (i > stack_max) |
a0d0e21e | 115 | break; |
d6721266 | 116 | PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); |
79072805 | 117 | } |
a0d0e21e | 118 | while (1); |
760ac839 | 119 | PerlIO_printf(Perl_debug_log, "\n"); |
d6721266 DM |
120 | #endif /* DEBUGGING */ |
121 | } | |
122 | ||
123 | ||
124 | /* dump the current stack */ | |
125 | ||
126 | I32 | |
127 | Perl_debstack(pTHX) | |
128 | { | |
129 | #ifndef SKIP_DEBUGGING | |
130 | if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) | |
131 | return 0; | |
132 | ||
133 | PerlIO_printf(Perl_debug_log, " => "); | |
134 | deb_stack_n(PL_stack_base, | |
135 | 0, | |
136 | PL_stack_sp - PL_stack_base, | |
137 | PL_curstackinfo->si_markoff, | |
138 | PL_markstack_ptr - PL_markstack); | |
139 | ||
140 | ||
1045810a | 141 | #endif /* SKIP_DEBUGGING */ |
79072805 LW |
142 | return 0; |
143 | } | |
d6721266 DM |
144 | |
145 | ||
146 | #ifdef DEBUGGING | |
147 | static char * si_names[] = { | |
148 | "UNKNOWN", | |
149 | "UNDEF", | |
150 | "MAIN", | |
151 | "MAGIC", | |
152 | "SORT", | |
153 | "SIGNAL", | |
154 | "OVERLOAD", | |
155 | "DESTROY", | |
156 | "WARNHOOK", | |
157 | "DIEHOOK", | |
158 | "REQUIRE" | |
159 | }; | |
160 | #endif | |
161 | ||
162 | /* display all stacks */ | |
163 | ||
164 | ||
165 | void | |
166 | Perl_deb_stack_all(pTHX) | |
167 | { | |
168 | #ifdef DEBUGGING | |
169 | I32 ix, si_ix; | |
170 | PERL_SI *si; | |
171 | PERL_CONTEXT *cx; | |
172 | ||
173 | /* rewind to start of chain */ | |
174 | si = PL_curstackinfo; | |
175 | while (si->si_prev) | |
176 | si = si->si_prev; | |
177 | ||
178 | si_ix=0; | |
179 | for (;;) | |
180 | { | |
181 | char *si_name; | |
182 | int si_name_ix = si->si_type+1; /* -1 is a valid index */ | |
183 | if (si_name_ix>= sizeof(si_names)) | |
184 | si_name = "????"; | |
185 | else | |
186 | si_name = si_names[si_name_ix]; | |
187 | PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n", | |
e922992d | 188 | (IV)si_ix, si_name); |
d6721266 DM |
189 | |
190 | for (ix=0; ix<=si->si_cxix; ix++) { | |
191 | ||
192 | cx = &(si->si_cxstack[ix]); | |
193 | PerlIO_printf(Perl_debug_log, | |
194 | " CX %"IVdf": %-6s => ", | |
f1fe7cd8 | 195 | (IV)ix, PL_block_type[CxTYPE(cx)] |
d6721266 DM |
196 | ); |
197 | /* substitution contexts don't save stack pointers etc) */ | |
198 | if (CxTYPE(cx) == CXt_SUBST) | |
199 | PerlIO_printf(Perl_debug_log, "\n"); | |
200 | else { | |
201 | ||
202 | /* Find the the current context's stack range by searching | |
203 | * forward for any higher contexts using this stack; failing | |
204 | * that, it will be equal to the size of the stack for old | |
205 | * stacks, or PL_stack_sp for the current stack | |
206 | */ | |
207 | ||
208 | I32 i, stack_min, stack_max, mark_min, mark_max; | |
209 | I32 ret_min, ret_max; | |
210 | PERL_CONTEXT *cx_n; | |
211 | PERL_SI *si_n; | |
212 | ||
213 | cx_n = Null(PERL_CONTEXT*); | |
214 | ||
215 | /* there's a separate stack per SI, so only search | |
216 | * this one */ | |
217 | ||
218 | for (i=ix+1; i<=si->si_cxix; i++) { | |
219 | if (CxTYPE(cx) == CXt_SUBST) | |
220 | continue; | |
221 | cx_n = &(si->si_cxstack[i]); | |
222 | break; | |
223 | } | |
224 | ||
225 | stack_min = cx->blk_oldsp; | |
226 | ||
227 | if (cx_n) { | |
228 | stack_max = cx_n->blk_oldsp; | |
229 | } | |
230 | else if (si == PL_curstackinfo) { | |
231 | stack_max = PL_stack_sp - AvARRAY(si->si_stack); | |
232 | } | |
233 | else { | |
234 | stack_max = AvFILLp(si->si_stack); | |
235 | } | |
236 | ||
237 | /* for the other stack types, there's only one stack | |
238 | * shared between all SIs */ | |
239 | ||
240 | si_n = si; | |
241 | i = ix; | |
242 | cx_n = Null(PERL_CONTEXT*); | |
243 | for (;;) { | |
244 | i++; | |
245 | if (i > si_n->si_cxix) { | |
246 | if (si_n == PL_curstackinfo) | |
247 | break; | |
248 | else { | |
249 | si_n = si_n->si_next; | |
250 | i = 0; | |
251 | } | |
252 | } | |
253 | if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) | |
254 | continue; | |
255 | cx_n = &(si_n->si_cxstack[i]); | |
256 | break; | |
257 | } | |
258 | ||
259 | mark_min = cx->blk_oldmarksp; | |
260 | ret_min = cx->blk_oldretsp; | |
261 | if (cx_n) { | |
262 | mark_max = cx_n->blk_oldmarksp; | |
263 | ret_max = cx_n->blk_oldretsp; | |
264 | } | |
265 | else { | |
266 | mark_max = PL_markstack_ptr - PL_markstack; | |
267 | ret_max = PL_retstack_ix; | |
268 | } | |
269 | ||
270 | deb_stack_n(AvARRAY(si->si_stack), | |
271 | stack_min, stack_max, mark_min, mark_max); | |
272 | ||
273 | if (ret_max > ret_min) { | |
274 | PerlIO_printf(Perl_debug_log, " retop=%s\n", | |
275 | PL_retstack[ret_min] | |
276 | ? OP_NAME(PL_retstack[ret_min]) | |
277 | : "(null)" | |
278 | ); | |
279 | } | |
280 | ||
281 | } | |
282 | } /* next context */ | |
283 | ||
284 | ||
285 | if (si == PL_curstackinfo) | |
286 | break; | |
287 | si = si->si_next; | |
288 | si_ix++; | |
289 | if (!si) | |
290 | break; /* shouldn't happen, but just in case.. */ | |
291 | } /* next stackinfo */ | |
292 | ||
293 | PerlIO_printf(Perl_debug_log, "\n"); | |
294 | #endif /* DEBUGGING */ | |
295 | } | |
296 | ||
297 |