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 I32
  82 Perl_debstack(pTHX)
  83 {
  84 #ifndef SKIP_DEBUGGING
  85     I32 top = PL_stack_sp - PL_stack_base;
  86     register I32 i = top - 30;
  87     I32 *markscan = PL_markstack + PL_curstackinfo->si_markoff;
  88
  89     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
  90         return 0;
  91
  92     if (i < 0)
  93         i = 0;
  94
  95     while (++markscan <= PL_markstack_ptr)
  96         if (*markscan >= i)
  97             break;
  98
  99 #ifdef USE_5005THREADS
 100     PerlIO_printf(Perl_debug_log,
 101                   i ? "0x%"UVxf"    =>  ...  " : "0x%lx    =>  ",
 102                   PTR2UV(thr));
 103 #else
 104     PerlIO_printf(Perl_debug_log, i ? "    =>  ...  " : "    =>  ");
 105 #endif /* USE_5005THREADS */
 106     if (PL_stack_base[0] != &PL_sv_undef || PL_stack_sp < PL_stack_base)
 107         PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
 108     do {
 109         ++i;
 110         if (markscan <= PL_markstack_ptr && *markscan < i) {
 111             do {
 112                 ++markscan;
 113                 PerlIO_putc(Perl_debug_log, '*');
 114             }
 115             while (markscan <= PL_markstack_ptr && *markscan < i);
 116             PerlIO_printf(Perl_debug_log, "  ");
 117         }
 118         if (i > top)
 119             break;
 120         PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(PL_stack_base[i]));
 121     }
 122     while (1);
 123     PerlIO_printf(Perl_debug_log, "\n");
 124 #endif /* SKIP_DEBUGGING */
 125     return 0;
 126 }