deb.c

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