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