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     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                     cx_n = &(si_n->si_cxstack[i]);
 324                     break;
 325                 }
 326
 327                 mark_min  = cx->blk_oldmarksp;
 328                 if (cx_n) {
 329                     mark_max  = cx_n->blk_oldmarksp;
 330                 }
 331                 else {
 332                     mark_max = PL_markstack_ptr - PL_markstack;
 333                 }
 334
 335                 deb_stack_n(AvARRAY(si->si_stack),
 336                         stack_min, stack_max, mark_min, mark_max);
 337
 338                 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
 339                         || CxTYPE(cx) == CXt_FORMAT)
 340                 {
 341                     const OP * const retop = cx->blk_sub.retop;
 342
 343                     PerlIO_printf(Perl_debug_log, "  retop=%s\n",
 344                             retop ? OP_NAME(retop) : "(null)"
 345                     );
 346                 }
 347             }
 348         } /* next context */
 349
 350
 351         if (si == PL_curstackinfo)
 352             break;
 353         si = si->si_next;
 354         si_ix++;
 355         if (!si)
 356             break; /* shouldn't happen, but just in case.. */
 357     } /* next stackinfo */
 358
 359     PerlIO_printf(Perl_debug_log, "\n");
 360 #else
 361     PERL_UNUSED_CONTEXT;
 362 #endif /* DEBUGGING */
 363 }
 364
 365 /*
 366  * ex: set ts=8 sts=4 sw=4 et:
 367  */