Add a test for [perl #17753].
[p5sagit/p5-mst-13.2.git] / deb.c
1 /*    deb.c
2  *
3  *    Copyright (c) 1991-2002, Larry Wall
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  *
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
13  */
14
15 #include "EXTERN.h"
16 #define PERL_IN_DEB_C
17 #include "perl.h"
18
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
33 void
34 Perl_deb(pTHX_ const char *pat, ...)
35 {
36 #ifdef DEBUGGING
37     va_list args;
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
48     char* file = OutCopFILE(PL_curcop);
49
50     PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
51                   (long)CopLINE(PL_curcop));
52     (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
53 #endif /* DEBUGGING */
54 }
55
56 I32
57 Perl_debstackptrs(pTHX)
58 {
59 #ifdef DEBUGGING
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)));
70 #endif /* DEBUGGING */
71     return 0;
72 }
73
74
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  */
83
84 STATIC void
85 S_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;
93     
94     while (++markscan <= PL_markstack + mark_max)
95         if (*markscan >= i)
96             break;
97
98     if (i > stack_min)
99         PerlIO_printf(Perl_debug_log, "... ");
100
101     if (stack_base[0] != &PL_sv_undef || stack_max < 0)
102         PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
103     do {
104         ++i;
105         if (markscan <= PL_markstack + mark_max && *markscan < i) {
106             do {
107                 ++markscan;
108                 PerlIO_putc(Perl_debug_log, '*');
109             }
110             while (markscan <= PL_markstack + mark_max && *markscan < i);
111             PerlIO_printf(Perl_debug_log, "  ");
112         }
113         if (i > stack_max)
114             break;
115         PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(stack_base[i]));
116     }
117     while (1);
118     PerlIO_printf(Perl_debug_log, "\n");
119 #endif /* DEBUGGING */
120 }
121
122
123 /* dump the current stack */
124
125 I32
126 Perl_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
140 #endif /* SKIP_DEBUGGING */
141     return 0;
142 }
143
144
145 #ifdef DEBUGGING
146 static 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
164 void
165 Perl_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",
187                                                 (IV)si_ix, si_name);
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 => ",
194                     (IV)ix, PL_block_type[CxTYPE(cx)]
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