deb.c

   1 /*    deb.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 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, I
  13  * have seen more than thou knowest, Gray Fool."  --Denethor
  14  */
  15
  16 /*
  17  * This file contains various utilities for producing debugging output
  18  * (mainly related to displaying the stack)
  19  */
  20
  21 #include "EXTERN.h"
  22 #define PERL_IN_DEB_C
  23 #include "perl.h"
  24
  25 #if defined(PERL_IMPLICIT_CONTEXT)
  26 void
  27 Perl_deb_nocontext(const char *pat, ...)
  28 {
  29 #ifdef DEBUGGING
  30     dTHX;
  31     va_list args;
  32     va_start(args, pat);
  33     vdeb(pat, &args);
  34     va_end(args);
  35 #endif /* DEBUGGING */
  36 }
  37 #endif
  38
  39 void
  40 Perl_deb(pTHX_ const char *pat, ...)
  41 {
  42 #ifdef DEBUGGING
  43     va_list args;
  44     va_start(args, pat);
  45     vdeb(pat, &args);
  46     va_end(args);
  47 #else
  48     PERL_UNUSED_ARG(pat);
  49 #endif /* DEBUGGING */
  50 }
  51
  52 void
  53 Perl_vdeb(pTHX_ const char *pat, va_list *args)
  54 {
  55 #ifdef DEBUGGING
  56     char* file = OutCopFILE(PL_curcop);
  57
  58     PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", (file ? file : "<free>"),
  59                   (long)CopLINE(PL_curcop));
  60     (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
  61 #else
  62     PERL_UNUSED_ARG(pat);
  63     PERL_UNUSED_ARG(args);
  64 #endif /* DEBUGGING */
  65 }
  66
  67 I32
  68 Perl_debstackptrs(pTHX)
  69 {
  70 #ifdef DEBUGGING
  71     PerlIO_printf(Perl_debug_log,
  72                   "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
  73                   PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
  74                   (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
  75                   (IV)(PL_stack_max-PL_stack_base));
  76     PerlIO_printf(Perl_debug_log,
  77                   "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
  78                   PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
  79                   PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
  80                   PTR2UV(AvMAX(PL_curstack)));
  81 #endif /* DEBUGGING */
  82     return 0;
  83 }
  84
  85
  86 /* dump the contents of a particular stack
  87  * Display stack_base[stack_min+1 .. stack_max],
  88  * and display the marks whose offsets are contained in addresses
  89  * PL_markstack[mark_min+1 .. mark_max] and whose values are in the range
  90  * of the stack values being displayed
  91  *
  92  * Only displays top 30 max
  93  */
  94
  95 STATIC void
  96 S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
  97         I32 mark_min, I32 mark_max)
  98 {
  99 #ifdef DEBUGGING
 100     register I32 i = stack_max - 30;
 101     const I32 *markscan = PL_markstack + mark_min;
 102     if (i < stack_min)
 103         i = stack_min;
 104
 105     while (++markscan <= PL_markstack + mark_max)
 106         if (*markscan >= i)
 107             break;
 108
 109     if (i > stack_min)
 110         PerlIO_printf(Perl_debug_log, "... ");
 111
 112     if (stack_base[0] != &PL_sv_undef || stack_max < 0)
 113         PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
 114     do {
 115         ++i;
 116         if (markscan <= PL_markstack + mark_max && *markscan < i) {
 117             do {
 118                 ++markscan;
 119                 PerlIO_putc(Perl_debug_log, '*');
 120             }
 121             while (markscan <= PL_markstack + mark_max && *markscan < i);
 122             PerlIO_printf(Perl_debug_log, "  ");
 123         }
 124         if (i > stack_max)
 125             break;
 126         PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(stack_base[i]));
 127     }
 128     while (1);
 129     PerlIO_printf(Perl_debug_log, "\n");
 130 #else
 131     PERL_UNUSED_ARG(stack_base);
 132     PERL_UNUSED_ARG(stack_min);
 133     PERL_UNUSED_ARG(stack_max);
 134     PERL_UNUSED_ARG(mark_min);
 135     PERL_UNUSED_ARG(mark_max);
 136 #endif /* DEBUGGING */
 137 }
 138
 139
 140 /* dump the current stack */
 141
 142 I32
 143 Perl_debstack(pTHX)
 144 {
 145 #ifndef SKIP_DEBUGGING
 146     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
 147         return 0;
 148
 149     PerlIO_printf(Perl_debug_log, "    =>  ");
 150     deb_stack_n(PL_stack_base,
 151                 0,
 152                 PL_stack_sp - PL_stack_base,
 153                 PL_curstackinfo->si_markoff,
 154                 PL_markstack_ptr - PL_markstack);
 155
 156
 157 #endif /* SKIP_DEBUGGING */
 158     return 0;
 159 }
 160
 161
 162 #ifdef DEBUGGING
 163 static const char * const si_names[] = {
 164     "UNKNOWN",
 165     "UNDEF",
 166     "MAIN",
 167     "MAGIC",
 168     "SORT",
 169     "SIGNAL",
 170     "OVERLOAD",
 171     "DESTROY",
 172     "WARNHOOK",
 173     "DIEHOOK",
 174     "REQUIRE"
 175 };
 176 #endif
 177
 178 /* display all stacks */
 179
 180
 181 void
 182 Perl_deb_stack_all(pTHX)
 183 {
 184 #ifdef DEBUGGING
 185     I32 si_ix;
 186     const PERL_SI *si;
 187
 188     /* rewind to start of chain */
 189     si = PL_curstackinfo;
 190     while (si->si_prev)
 191         si = si->si_prev;
 192
 193     si_ix=0;
 194     for (;;)
 195     {
 196         const int si_name_ix = si->si_type+1; /* -1 is a valid index */
 197         const char * const si_name = (si_name_ix>= sizeof(si_names)) ? "????" : si_names[si_name_ix];
 198         I32 ix;
 199         PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
 200                                                 (IV)si_ix, si_name);
 201
 202         for (ix=0; ix<=si->si_cxix; ix++) {
 203
 204             const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
 205             PerlIO_printf(Perl_debug_log,
 206                     "  CX %"IVdf": %-6s => ",
 207                     (IV)ix, PL_block_type[CxTYPE(cx)]
 208             );
 209             /* substitution contexts don't save stack pointers etc) */
 210             if (CxTYPE(cx) == CXt_SUBST)
 211                 PerlIO_printf(Perl_debug_log, "\n");
 212             else {
 213
 214                 /* Find the the current context's stack range by searching
 215                  * forward for any higher contexts using this stack; failing
 216                  * that, it will be equal to the size of the stack for old
 217                  * stacks, or PL_stack_sp for the current stack
 218                  */
 219
 220                 I32 i, stack_min, stack_max, mark_min, mark_max;
 221                 const PERL_CONTEXT *cx_n;
 222                 const PERL_SI *si_n;
 223
 224                 cx_n = Null(PERL_CONTEXT*);
 225
 226                 /* there's a separate stack per SI, so only search
 227                  * this one */
 228
 229                 for (i=ix+1; i<=si->si_cxix; i++) {
 230                     if (CxTYPE(cx) == CXt_SUBST)
 231                         continue;
 232                     cx_n = &(si->si_cxstack[i]);
 233                     break;
 234                 }
 235
 236                 stack_min = cx->blk_oldsp;
 237
 238                 if (cx_n) {
 239                     stack_max = cx_n->blk_oldsp;
 240                 }
 241                 else if (si == PL_curstackinfo) {
 242                     stack_max = PL_stack_sp - AvARRAY(si->si_stack);
 243                 }
 244                 else {
 245                     stack_max = AvFILLp(si->si_stack);
 246                 }
 247
 248                 /* for the other stack types, there's only one stack
 249                  * shared between all SIs */
 250
 251                 si_n = si;
 252                 i = ix;
 253                 cx_n = Null(PERL_CONTEXT*);
 254                 for (;;) {
 255                     i++;
 256                     if (i > si_n->si_cxix) {
 257                         if (si_n == PL_curstackinfo)
 258                             break;
 259                         else {
 260                             si_n = si_n->si_next;
 261                             i = 0;
 262                         }
 263                     }
 264                     if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
 265                         continue;
 266                     cx_n = &(si_n->si_cxstack[i]);
 267                     break;
 268                 }
 269
 270                 mark_min  = cx->blk_oldmarksp;
 271                 if (cx_n) {
 272                     mark_max  = cx_n->blk_oldmarksp;
 273                 }
 274                 else {
 275                     mark_max = PL_markstack_ptr - PL_markstack;
 276                 }
 277
 278                 deb_stack_n(AvARRAY(si->si_stack),
 279                         stack_min, stack_max, mark_min, mark_max);
 280
 281                 if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
 282                         || CxTYPE(cx) == CXt_FORMAT)
 283                 {
 284                     const OP * const retop = (CxTYPE(cx) == CXt_EVAL)
 285                             ? cx->blk_eval.retop : cx->blk_sub.retop;
 286
 287                     PerlIO_printf(Perl_debug_log, "  retop=%s\n",
 288                             retop ? OP_NAME(retop) : "(null)"
 289                     );
 290                 }
 291             }
 292         } /* next context */
 293
 294
 295         if (si == PL_curstackinfo)
 296             break;
 297         si = si->si_next;
 298         si_ix++;
 299         if (!si)
 300             break; /* shouldn't happen, but just in case.. */
 301     } /* next stackinfo */
 302
 303     PerlIO_printf(Perl_debug_log, "\n");
 304 #endif /* DEBUGGING */
 305 }
 306
 307 /*
 308  * Local variables:
 309  * c-indentation-style: bsd
 310  * c-basic-offset: 4
 311  * indent-tabs-mode: t
 312  * End:
 313  *
 314  * ex: set ts=8 sts=4 sw=4 noet:
 315  */