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