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 * 137 * Only displays top 30 max 138 */ 139 140 STATIC void 141 S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, 142 I32 mark_min, I32 mark_max) 143 { 144 #ifdef DEBUGGING 145 I32 i = stack_max - 30; 146 const I32 *markscan = PL_markstack + mark_min; 147 148 PERL_ARGS_ASSERT_DEB_STACK_N; 149 150 if (i < stack_min) 151 i = stack_min; 152 153 while (++markscan <= PL_markstack + mark_max) 154 if (*markscan >= i) 155 break; 156 157 if (i > stack_min) 158 PerlIO_printf(Perl_debug_log, "... "); 159 160 if (stack_base[0] != &PL_sv_undef || stack_max < 0) 161 PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); 162 do { 163 ++i; 164 if (markscan <= PL_markstack + mark_max && *markscan < i) { 165 do { 166 ++markscan; 167 (void)PerlIO_putc(Perl_debug_log, '*'); 168 } 169 while (markscan <= PL_markstack + mark_max && *markscan < i); 170 PerlIO_printf(Perl_debug_log, " "); 171 } 172 if (i > stack_max) 173 break; 174 PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); 175 } 176 while (1); 177 PerlIO_printf(Perl_debug_log, "\n"); 178 #else 179 PERL_UNUSED_CONTEXT; 180 PERL_UNUSED_ARG(stack_base); 181 PERL_UNUSED_ARG(stack_min); 182 PERL_UNUSED_ARG(stack_max); 183 PERL_UNUSED_ARG(mark_min); 184 PERL_UNUSED_ARG(mark_max); 185 #endif /* DEBUGGING */ 186 } 187 188 189 /* 190 =for apidoc debstack 191 192 Dump the current stack 193 194 =cut 195 */ 196 197 I32 198 Perl_debstack(pTHX) 199 { 200 #ifndef SKIP_DEBUGGING 201 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 202 return 0; 203 204 PerlIO_printf(Perl_debug_log, " => "); 205 deb_stack_n(PL_stack_base, 206 0, 207 PL_stack_sp - PL_stack_base, 208 PL_curstackinfo->si_markoff, 209 PL_markstack_ptr - PL_markstack); 210 211 212 #endif /* SKIP_DEBUGGING */ 213 return 0; 214 } 215 216 217 #ifdef DEBUGGING 218 static const char * const si_names[] = { 219 "UNKNOWN", 220 "UNDEF", 221 "MAIN", 222 "MAGIC", 223 "SORT", 224 "SIGNAL", 225 "OVERLOAD", 226 "DESTROY", 227 "WARNHOOK", 228 "DIEHOOK", 229 "REQUIRE", 230 "MULTICALL" 231 }; 232 #endif 233 234 /* display all stacks */ 235 236 237 void 238 Perl_deb_stack_all(pTHX) 239 { 240 #ifdef DEBUGGING 241 I32 si_ix; 242 const PERL_SI *si; 243 244 /* rewind to start of chain */ 245 si = PL_curstackinfo; 246 while (si->si_prev) 247 si = si->si_prev; 248 249 si_ix=0; 250 for (;;) 251 { 252 const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */ 253 const char * const si_name = 254 si_name_ix < C_ARRAY_LENGTH(si_names) ? 255 si_names[si_name_ix] : "????"; 256 I32 ix; 257 PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", 258 (IV)si_ix, si_name); 259 260 for (ix=0; ix<=si->si_cxix; ix++) { 261 262 const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); 263 PerlIO_printf(Perl_debug_log, 264 " CX %" IVdf ": %-6s => ", 265 (IV)ix, PL_block_type[CxTYPE(cx)] 266 ); 267 /* substitution contexts don't save stack pointers etc) */ 268 if (CxTYPE(cx) == CXt_SUBST) 269 PerlIO_printf(Perl_debug_log, "\n"); 270 else { 271 272 /* Find the current context's stack range by searching 273 * forward for any higher contexts using this stack; failing 274 * that, it will be equal to the size of the stack for old 275 * stacks, or PL_stack_sp for the current stack 276 */ 277 278 I32 i, stack_min, stack_max, mark_min, mark_max; 279 const PERL_CONTEXT *cx_n = NULL; 280 const PERL_SI *si_n; 281 282 /* there's a separate argument stack per SI, so only 283 * search this one */ 284 285 for (i=ix+1; i<=si->si_cxix; i++) { 286 const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); 287 if (CxTYPE(this_cx) == CXt_SUBST) 288 continue; 289 cx_n = this_cx; 290 break; 291 } 292 293 stack_min = cx->blk_oldsp; 294 295 if (cx_n) { 296 stack_max = cx_n->blk_oldsp; 297 } 298 else if (si == PL_curstackinfo) { 299 stack_max = PL_stack_sp - AvARRAY(si->si_stack); 300 } 301 else { 302 stack_max = AvFILLp(si->si_stack); 303 } 304 305 /* for the markstack, there's only one stack shared 306 * between all SIs */ 307 308 si_n = si; 309 i = ix; 310 cx_n = NULL; 311 for (;;) { 312 i++; 313 if (i > si_n->si_cxix) { 314 if (si_n == PL_curstackinfo) 315 break; 316 else { 317 si_n = si_n->si_next; 318 i = 0; 319 } 320 } 321 if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) 322 continue; 323 if (si_n->si_cxix >= 0) 324 cx_n = &(si_n->si_cxstack[i]); 325 else 326 cx_n = NULL; 327 break; 328 } 329 330 mark_min = cx->blk_oldmarksp; 331 if (cx_n) { 332 mark_max = cx_n->blk_oldmarksp; 333 } 334 else { 335 mark_max = PL_markstack_ptr - PL_markstack; 336 } 337 338 deb_stack_n(AvARRAY(si->si_stack), 339 stack_min, stack_max, mark_min, mark_max); 340 341 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB 342 || CxTYPE(cx) == CXt_FORMAT) 343 { 344 const OP * const retop = cx->blk_sub.retop; 345 346 PerlIO_printf(Perl_debug_log, " retop=%s\n", 347 retop ? OP_NAME(retop) : "(null)" 348 ); 349 } 350 } 351 } /* next context */ 352 353 354 if (si == PL_curstackinfo) 355 break; 356 si = si->si_next; 357 si_ix++; 358 if (!si) 359 break; /* shouldn't happen, but just in case.. */ 360 } /* next stackinfo */ 361 362 PerlIO_printf(Perl_debug_log, "\n"); 363 #else 364 PERL_UNUSED_CONTEXT; 365 #endif /* DEBUGGING */ 366 } 367 368 /* 369 * ex: set ts=8 sts=4 sw=4 et: 370 */ 371