deb.c

   1 /*    deb.c
   2  *
   3  *    Copyright (c) 1991-1994, 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 #include "perl.h"
  17
  18 #ifdef DEBUGGING
  19 #if !defined(I_STDARG) && !defined(I_VARARGS)
  20
  21 /*
  22  * Fallback on the old hackers way of doing varargs
  23  */
  24
  25 /*VARARGS1*/
  26 void
  27 deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
  28     char *pat;
  29 {
  30     register I32 i;
  31     GV* gv = curcop->cop_filegv;
  32
  33     PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
  34         SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
  35         (long)curcop->cop_line);
  36     for (i=0; i<dlevel; i++)
  37         PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
  38     PerlIO_printf(Perl_debug_log, pat,a1,a2,a3,a4,a5,a6,a7,a8);
  39 }
  40
  41 #else /* !defined(I_STDARG) && !defined(I_VARARGS) */
  42
  43 #  ifdef I_STDARG
  44 void
  45 deb(const char *pat, ...)
  46 #  else
  47 /*VARARGS1*/
  48 void
  49 deb(pat, va_alist)
  50     const char *pat;
  51     va_dcl
  52 #  endif
  53 {
  54     va_list args;
  55     register I32 i;
  56     GV* gv = curcop->cop_filegv;
  57
  58     PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
  59         SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
  60         (long)curcop->cop_line);
  61     for (i=0; i<dlevel; i++)
  62         PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
  63
  64 #  ifdef I_STDARG
  65     va_start(args, pat);
  66 #  else
  67     va_start(args);
  68 #  endif
  69     (void) PerlIO_vprintf(Perl_debug_log,pat,args);
  70     va_end( args );
  71 }
  72 #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
  73
  74 void
  75 deb_growlevel()
  76 {
  77     dlmax += 128;
  78     Renew(debname, dlmax, char);
  79     Renew(debdelim, dlmax, char);
  80 }
  81
  82 I32
  83 debstackptrs()
  84 {
  85     PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
  86         (unsigned long)curstack, (unsigned long)stack_base,
  87         (long)*markstack_ptr, (long)(stack_sp-stack_base),
  88         (long)(stack_max-stack_base));
  89     PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
  90         (unsigned long)mainstack, (unsigned long)AvARRAY(curstack),
  91         (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack));
  92     return 0;
  93 }
  94
  95 I32
  96 debstack()
  97 {
  98     I32 top = stack_sp - stack_base;
  99     register I32 i = top - 30;
 100     I32 *markscan = markstack;
 101
 102     if (i < 0)
 103         i = 0;
 104
 105     while (++markscan <= markstack_ptr)
 106         if (*markscan >= i)
 107             break;
 108
 109     PerlIO_printf(Perl_debug_log, i ? "    =>  ...  " : "    =>  ");
 110     if (stack_base[0] != &sv_undef || stack_sp < stack_base)
 111         PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
 112     do {
 113         ++i;
 114         if (markscan <= markstack_ptr && *markscan < i) {
 115             do {
 116                 ++markscan;
 117                 PerlIO_putc(Perl_debug_log, '*');
 118             }
 119             while (markscan <= markstack_ptr && *markscan < i);
 120             PerlIO_printf(Perl_debug_log, "  ");
 121         }
 122         if (i > top)
 123             break;
 124         PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(stack_base[i]));
 125     }
 126     while (1);
 127     PerlIO_printf(Perl_debug_log, "\n");
 128     return 0;
 129 }
 130 #else
 131 static int dummy; /* avoid totally empty deb.o file */
 132 #endif /* DEBUGGING */