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