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