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