Encode tweaks for VMS
[perl.git] / 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 }