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