1 /* deb.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 4 * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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, 13 * I have seen more than thou knowest, Grey Fool.' --Denethor 14 * 15 * [p.853 of _The Lord of the Rings_, V/vii: "The Pyre of Denethor"] 16 */ 17 18 /* 19 * This file contains various utilities for producing debugging output 20 * (mainly related to displaying the stack) 21 */ 22 23 #include "EXTERN.h" 24 #define PERL_IN_DEB_C 25 #include "perl.h" 26 27 #if defined(MULTIPLICITY) 28 void 29 Perl_deb_nocontext(const char *pat, ...) 30 { 31 #ifdef DEBUGGING 32 dTHX; 33 va_list args; 34 PERL_ARGS_ASSERT_DEB_NOCONTEXT; 35 va_start(args, pat); 36 vdeb(pat, &args); 37 va_end(args); 38 #else 39 PERL_UNUSED_ARG(pat); 40 #endif /* DEBUGGING */ 41 } 42 #endif 43 44 /* 45 =for apidoc deb 46 =for apidoc_item deb_nocontext 47 48 When perl is compiled with C<-DDEBUGGING>, this prints to STDERR the 49 information given by the arguments, prefaced by the name of the file containing 50 the script causing the call, and the line number within that file. 51 52 If the C<v> (verbose) debugging option is in effect, the process id is also 53 printed. 54 55 The two forms differ only in that C<deb_nocontext> does not take a thread 56 context (C<aTHX>) parameter, so is used in situations where the caller doesn't 57 already have the thread context. 58 59 =cut 60 */ 61 62 void 63 Perl_deb(pTHX_ const char *pat, ...) 64 { 65 va_list args; 66 PERL_ARGS_ASSERT_DEB; 67 va_start(args, pat); 68 #ifdef DEBUGGING 69 vdeb(pat, &args); 70 #else 71 PERL_UNUSED_CONTEXT; 72 #endif /* DEBUGGING */ 73 va_end(args); 74 } 75 76 /* 77 =for apidoc vdeb 78 79 This is like C<L</deb>>, but C<args> are an encapsulated argument list. 80 81 =cut 82 */ 83 84 void 85 Perl_vdeb(pTHX_ const char *pat, va_list *args) 86 { 87 #ifdef DEBUGGING 88 const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>"; 89 const char* const display_file = file ? file : "<free>"; 90 line_t line = PL_curcop ? CopLINE(PL_curcop) : NOLINE; 91 if (line == NOLINE) 92 line = 0; 93 94 PERL_ARGS_ASSERT_VDEB; 95 96 if (DEBUG_v_TEST) 97 PerlIO_printf(Perl_debug_log, "(%ld:%s:%" LINE_Tf ")\t", 98 (long)PerlProc_getpid(), display_file, line); 99 else 100 PerlIO_printf(Perl_debug_log, "(%s:%" LINE_Tf ")\t", 101 display_file, line); 102 (void) PerlIO_vprintf(Perl_debug_log, pat, *args); 103 #else 104 PERL_UNUSED_CONTEXT; 105 PERL_UNUSED_ARG(pat); 106 PERL_UNUSED_ARG(args); 107 #endif /* DEBUGGING */ 108 } 109 110 I32 111 Perl_debstackptrs(pTHX) /* Currently unused in cpan and core */ 112 { 113 #ifdef DEBUGGING 114 PerlIO_printf(Perl_debug_log, 115 "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", 116 PTR2UV(PL_curstack), PTR2UV(PL_stack_base), 117 (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), 118 (IV)(PL_stack_max-PL_stack_base)); 119 PerlIO_printf(Perl_debug_log, 120 "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", 121 PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), 122 PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), 123 PTR2UV(AvMAX(PL_curstack))); 124 #else 125 PERL_UNUSED_CONTEXT; 126 #endif /* DEBUGGING */ 127 return 0; 128 } 129 130 131 /* dump the contents of a particular stack 132 * Display stack_base[stack_min+1 .. stack_max], 133 * and display the marks whose offsets are contained in addresses 134 * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range 135 * of the stack values being displayed 136 * On PERL_RC_STACK builds, nonrc_base indicates the lowest 137 * non-reference-counted stack element (or 0 if none or not such a build). 138 * Display a vertical bar at this position. 139 * 140 * Only displays top 30 max 141 */ 142 143 STATIC void 144 S_deb_stack_n(pTHX_ SV** stack_base, SSize_t stack_min, SSize_t stack_max, 145 SSize_t mark_min, SSize_t mark_max, SSize_t nonrc_base) 146 { 147 #ifdef DEBUGGING 148 SSize_t i = stack_max - 30; 149 const Stack_off_t *markscan = PL_markstack + mark_min; 150 151 PERL_ARGS_ASSERT_DEB_STACK_N; 152 153 if (i < stack_min) 154 i = stack_min; 155 156 while (++markscan <= PL_markstack + mark_max) 157 if (*markscan >= i) 158 break; 159 160 if (i > stack_min) 161 PerlIO_printf(Perl_debug_log, "... "); 162 163 if (stack_base[0] != &PL_sv_undef || stack_max < 0) 164 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); 165 do { 166 ++i; 167 if (markscan <= PL_markstack + mark_max && *markscan < i) { 168 do { 169 ++markscan; 170 (void)PerlIO_putc(Perl_debug_log, '*'); 171 } 172 while (markscan <= PL_markstack + mark_max && *markscan < i); 173 PerlIO_printf(Perl_debug_log, " "); 174 } 175 if (i > stack_max) 176 break; 177 178 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); 179 180 if (nonrc_base && nonrc_base == i + 1) 181 PerlIO_printf(Perl_debug_log, "| "); 182 } 183 while (1); 184 PerlIO_printf(Perl_debug_log, "\n"); 185 #else 186 PERL_UNUSED_CONTEXT; 187 PERL_UNUSED_ARG(stack_base); 188 PERL_UNUSED_ARG(stack_min); 189 PERL_UNUSED_ARG(stack_max); 190 PERL_UNUSED_ARG(mark_min); 191 PERL_UNUSED_ARG(mark_max); 192 PERL_UNUSED_ARG(nonrc_base); 193 #endif /* DEBUGGING */ 194 } 195 196 197 /* 198 =for apidoc debstack 199 200 Dump the current stack 201 202 =cut 203 */ 204 205 I32 206 Perl_debstack(pTHX) 207 { 208 #ifndef SKIP_DEBUGGING 209 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 210 return 0; 211 212 PerlIO_printf(Perl_debug_log, " => "); 213 S_deb_stack_n(aTHX_ PL_stack_base, 214 0, 215 PL_stack_sp - PL_stack_base, 216 PL_curstackinfo->si_markoff, 217 PL_markstack_ptr - PL_markstack, 218 # ifdef PERL_RC_STACK 219 PL_curstackinfo->si_stack_nonrc_base 220 # else 221 0 222 # endif 223 ); 224 225 226 #endif /* SKIP_DEBUGGING */ 227 return 0; 228 } 229 230 231 #ifdef DEBUGGING 232 static const char * const si_names[] = { 233 "UNKNOWN", 234 "UNDEF", 235 "MAIN", 236 "MAGIC", 237 "SORT", 238 "SIGNAL", 239 "OVERLOAD", 240 "DESTROY", 241 "WARNHOOK", 242 "DIEHOOK", 243 "REQUIRE", 244 "MULTICALL" 245 }; 246 #endif 247 248 /* display all stacks */ 249 250 251 void 252 Perl_deb_stack_all(pTHX) 253 { 254 #ifdef DEBUGGING 255 I32 si_ix; 256 const PERL_SI *si; 257 258 /* rewind to start of chain */ 259 si = PL_curstackinfo; 260 while (si->si_prev) 261 si = si->si_prev; 262 263 si_ix=0; 264 for (;;) 265 { 266 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ 267 const char * const si_name = 268 si_name_ix < C_ARRAY_LENGTH(si_names) ? 269 si_names[si_name_ix] : "????"; 270 I32 ix; 271 PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s%s\n", 272 (IV)si_ix, si_name, 273 # ifdef PERL_RC_STACK 274 AvREAL(si->si_stack) 275 ? (si->si_stack_nonrc_base ? " (partial real)" : " (real)") 276 : "" 277 # else 278 "" 279 # endif 280 ); 281 282 for (ix=0; ix<=si->si_cxix; ix++) { 283 284 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); 285 PerlIO_printf(Perl_debug_log, 286 " CX %" IVdf ": %-6s => ", 287 (IV)ix, PL_block_type[CxTYPE(cx)] 288 ); 289 /* substitution contexts don't save stack pointers etc) */ 290 if (CxTYPE(cx) == CXt_SUBST) 291 PerlIO_printf(Perl_debug_log, "\n"); 292 else { 293 294 /* Find the current context's stack range by searching 295 * forward for any higher contexts using this stack; failing 296 * that, it will be equal to the size of the stack for old 297 * stacks, or PL_stack_sp for the current stack 298 */ 299 300 I32 i, stack_min, stack_max, mark_min, mark_max; 301 const PERL_CONTEXT *cx_n = NULL; 302 const PERL_SI *si_n; 303 304 /* there's a separate argument stack per SI, so only 305 * search this one */ 306 307 for (i=ix+1; i<=si->si_cxix; i++) { 308 const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); 309 if (CxTYPE(this_cx) == CXt_SUBST) 310 continue; 311 cx_n = this_cx; 312 break; 313 } 314 315 stack_min = cx->blk_oldsp; 316 317 if (cx_n) { 318 stack_max = cx_n->blk_oldsp; 319 } 320 else if (si == PL_curstackinfo) { 321 stack_max = PL_stack_sp - AvARRAY(si->si_stack); 322 } 323 else { 324 stack_max = AvFILLp(si->si_stack); 325 } 326 327 /* for the markstack, there's only one stack shared 328 * between all SIs */ 329 330 si_n = si; 331 i = ix; 332 cx_n = NULL; 333 for (;;) { 334 i++; 335 if (i > si_n->si_cxix) { 336 if (si_n == PL_curstackinfo) 337 break; 338 else { 339 si_n = si_n->si_next; 340 i = 0; 341 } 342 } 343 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) 344 continue; 345 if (si_n->si_cxix >= 0) 346 cx_n = &(si_n->si_cxstack[i]); 347 else 348 cx_n = NULL; 349 break; 350 } 351 352 mark_min = cx->blk_oldmarksp; 353 if (cx_n) { 354 mark_max = cx_n->blk_oldmarksp; 355 } 356 else { 357 mark_max = PL_markstack_ptr - PL_markstack; 358 } 359 360 S_deb_stack_n(aTHX_ AvARRAY(si->si_stack), 361 stack_min, stack_max, mark_min, mark_max, 362 # ifdef PERL_RC_STACK 363 si->si_stack_nonrc_base 364 # else 365 0 366 # endif 367 ); 368 369 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB 370 || CxTYPE(cx) == CXt_FORMAT) 371 { 372 const OP * const retop = cx->blk_sub.retop; 373 374 PerlIO_printf(Perl_debug_log, " retop=%s\n", 375 retop ? OP_NAME(retop) : "(null)" 376 ); 377 } 378 } 379 } /* next context */ 380 381 382 if (si == PL_curstackinfo) 383 break; 384 si = si->si_next; 385 si_ix++; 386 if (!si) 387 break; /* shouldn't happen, but just in case.. */ 388 } /* next stackinfo */ 389 390 PerlIO_printf(Perl_debug_log, "\n"); 391 #else 392 PERL_UNUSED_CONTEXT; 393 #endif /* DEBUGGING */ 394 } 395 396 /* 397 * ex: set ts=8 sts=4 sw=4 et: 398 */ 399