Dethinko.
[p5sagit/p5-mst-13.2.git] / deb.c
1 /*    deb.c
2  *
3  *    Copyright (c) 1991-1999, 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     dTHR;
49     register I32 i;
50     GV* gv = PL_curcop->cop_filegv;
51
52 #ifdef USE_THREADS
53     PerlIO_printf(Perl_debug_log, "0x%lx (%s:%ld)\t",
54                   (unsigned long) thr,
55                   SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
56                   (long)PL_curcop->cop_line);
57 #else
58     PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
59         SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
60         (long)PL_curcop->cop_line);
61 #endif /* USE_THREADS */
62     for (i=0; i<PL_dlevel; i++)
63         PerlIO_printf(Perl_debug_log, "%c%c ",PL_debname[i],PL_debdelim[i]);
64     (void) PerlIO_vprintf(Perl_debug_log, pat, *args);
65 #endif /* DEBUGGING */
66 }
67
68 void
69 Perl_deb_growlevel(pTHX)
70 {
71 #ifdef DEBUGGING
72     PL_dlmax += 128;
73     Renew(PL_debname, PL_dlmax, char);
74     Renew(PL_debdelim, PL_dlmax, char);
75 #endif /* DEBUGGING */
76 }
77
78 I32
79 Perl_debstackptrs(pTHX)
80 {
81 #ifdef DEBUGGING
82     dTHR;
83     PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
84         (unsigned long)PL_curstack, (unsigned long)PL_stack_base,
85         (long)*PL_markstack_ptr, (long)(PL_stack_sp-PL_stack_base),
86         (long)(PL_stack_max-PL_stack_base));
87     PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
88         (unsigned long)PL_mainstack, (unsigned long)AvARRAY(PL_curstack),
89         (long)PL_mainstack, (long)AvFILLp(PL_curstack), (long)AvMAX(PL_curstack));
90 #endif /* DEBUGGING */
91     return 0;
92 }
93
94 I32
95 Perl_debstack(pTHX)
96 {
97 #ifdef DEBUGGING
98     dTHR;
99     I32 top = PL_stack_sp - PL_stack_base;
100     register I32 i = top - 30;
101     I32 *markscan = PL_curstackinfo->si_markbase;
102
103     if (i < 0)
104         i = 0;
105     
106     while (++markscan <= PL_markstack_ptr)
107         if (*markscan >= i)
108             break;
109
110 #ifdef USE_THREADS
111     PerlIO_printf(Perl_debug_log, i ? "0x%lx    =>  ...  " : "0x%lx    =>  ",
112                   (unsigned long) thr);
113 #else
114     PerlIO_printf(Perl_debug_log, i ? "    =>  ...  " : "    =>  ");
115 #endif /* USE_THREADS */
116     if (PL_stack_base[0] != &PL_sv_undef || PL_stack_sp < PL_stack_base)
117         PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
118     do {
119         ++i;
120         if (markscan <= PL_markstack_ptr && *markscan < i) {
121             do {
122                 ++markscan;
123                 PerlIO_putc(Perl_debug_log, '*');
124             }
125             while (markscan <= PL_markstack_ptr && *markscan < i);
126             PerlIO_printf(Perl_debug_log, "  ");
127         }
128         if (i > top)
129             break;
130         PerlIO_printf(Perl_debug_log, "%-4s  ", SvPEEK(PL_stack_base[i]));
131     }
132     while (1);
133     PerlIO_printf(Perl_debug_log, "\n");
134 #endif /* DEBUGGING */
135     return 0;
136 }