deb.c

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