/* deb.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000,
- * 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "Didst thou think that the eyes of the White Tower were blind? Nay, I
- * have seen more than thou knowest, Gray Fool." --Denethor
+ * 'Didst thou think that the eyes of the White Tower were blind? Nay,
+ * I have seen more than thou knowest, Grey Fool.' --Denethor
+ *
+ * [p.853 of _The Lord of the Rings_, V/vii: "The Pyre of Denethor"]
*/
/*
#define PERL_IN_DEB_C
#include "perl.h"
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
void
Perl_deb_nocontext(const char *pat, ...)
{
}
#endif
+/*
+=for apidoc deb
+=for apidoc_item deb_nocontext
+
+When perl is compiled with C<-DDEBUGGING>, this prints to STDERR the
+information given by the arguments, prefaced by the name of the file containing
+the script causing the call, and the line number within that file.
+
+If the C<v> (verbose) debugging option is in effect, the process id is also
+printed.
+
+The two forms differ only in that C<deb_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
+
+=cut
+*/
+
void
Perl_deb(pTHX_ const char *pat, ...)
{
va_end(args);
}
+/*
+=for apidoc vdeb
+
+This is like C<L</deb>>, but C<args> are an encapsulated argument list.
+
+=cut
+*/
+
void
Perl_vdeb(pTHX_ const char *pat, va_list *args)
{
#ifdef DEBUGGING
- dVAR;
const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
const char* const display_file = file ? file : "<free>";
- const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0;
+ long line = PL_curcop ? (long)CopLINE(PL_curcop) : NOLINE;
+ if (line == NOLINE)
+ line = 0;
PERL_ARGS_ASSERT_VDEB;
if (DEBUG_v_TEST)
- PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
- (long)PerlProc_getpid(), display_file, line);
+ PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
+ (long)PerlProc_getpid(), display_file, line);
else
- PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
+ PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
(void) PerlIO_vprintf(Perl_debug_log, pat, *args);
#else
PERL_UNUSED_CONTEXT;
}
I32
-Perl_debstackptrs(pTHX)
+Perl_debstackptrs(pTHX) /* Currently unused in cpan and core */
{
#ifdef DEBUGGING
- dVAR;
PerlIO_printf(Perl_debug_log,
- "%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
- PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
- (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
- (IV)(PL_stack_max-PL_stack_base));
+ "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n",
+ PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
+ (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
+ (IV)(PL_stack_max-PL_stack_base));
PerlIO_printf(Perl_debug_log,
- "%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
- PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
- PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
- PTR2UV(AvMAX(PL_curstack)));
+ "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n",
+ PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
+ PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
+ PTR2UV(AvMAX(PL_curstack)));
+#else
+ PERL_UNUSED_CONTEXT;
#endif /* DEBUGGING */
return 0;
}
STATIC void
S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
- I32 mark_min, I32 mark_max)
+ I32 mark_min, I32 mark_max)
{
#ifdef DEBUGGING
- dVAR;
- register I32 i = stack_max - 30;
+ I32 i = stack_max - 30;
const I32 *markscan = PL_markstack + mark_min;
PERL_ARGS_ASSERT_DEB_STACK_N;
if (i < stack_min)
- i = stack_min;
+ i = stack_min;
while (++markscan <= PL_markstack + mark_max)
- if (*markscan >= i)
- break;
+ if (*markscan >= i)
+ break;
if (i > stack_min)
- PerlIO_printf(Perl_debug_log, "... ");
+ PerlIO_printf(Perl_debug_log, "... ");
if (stack_base[0] != &PL_sv_undef || stack_max < 0)
- PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
+ PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
- ++i;
- if (markscan <= PL_markstack + mark_max && *markscan < i) {
- do {
- ++markscan;
- PerlIO_putc(Perl_debug_log, '*');
- }
- while (markscan <= PL_markstack + mark_max && *markscan < i);
- PerlIO_printf(Perl_debug_log, " ");
- }
- if (i > stack_max)
- break;
- PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
+ ++i;
+ if (markscan <= PL_markstack + mark_max && *markscan < i) {
+ do {
+ ++markscan;
+ (void)PerlIO_putc(Perl_debug_log, '*');
+ }
+ while (markscan <= PL_markstack + mark_max && *markscan < i);
+ PerlIO_printf(Perl_debug_log, " ");
+ }
+ if (i > stack_max)
+ break;
+ PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
PerlIO_printf(Perl_debug_log, "\n");
}
-/* dump the current stack */
+/*
+=for apidoc debstack
+
+Dump the current stack
+
+=cut
+*/
I32
Perl_debstack(pTHX)
{
#ifndef SKIP_DEBUGGING
- dVAR;
if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
- return 0;
+ return 0;
PerlIO_printf(Perl_debug_log, " => ");
deb_stack_n(PL_stack_base,
- 0,
- PL_stack_sp - PL_stack_base,
- PL_curstackinfo->si_markoff,
- PL_markstack_ptr - PL_markstack);
+ 0,
+ PL_stack_sp - PL_stack_base,
+ PL_curstackinfo->si_markoff,
+ PL_markstack_ptr - PL_markstack);
#endif /* SKIP_DEBUGGING */
"DESTROY",
"WARNHOOK",
"DIEHOOK",
- "REQUIRE"
+ "REQUIRE",
+ "MULTICALL"
};
#endif
Perl_deb_stack_all(pTHX)
{
#ifdef DEBUGGING
- dVAR;
I32 si_ix;
const PERL_SI *si;
/* rewind to start of chain */
si = PL_curstackinfo;
while (si->si_prev)
- si = si->si_prev;
+ si = si->si_prev;
si_ix=0;
for (;;)
{
const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
- const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix];
- I32 ix;
- PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
- (IV)si_ix, si_name);
-
- for (ix=0; ix<=si->si_cxix; ix++) {
-
- const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
- PerlIO_printf(Perl_debug_log,
- " CX %"IVdf": %-6s => ",
- (IV)ix, PL_block_type[CxTYPE(cx)]
- );
- /* substitution contexts don't save stack pointers etc) */
- if (CxTYPE(cx) == CXt_SUBST)
- PerlIO_printf(Perl_debug_log, "\n");
- else {
-
- /* Find the the current context's stack range by searching
- * forward for any higher contexts using this stack; failing
- * that, it will be equal to the size of the stack for old
- * stacks, or PL_stack_sp for the current stack
- */
-
- I32 i, stack_min, stack_max, mark_min, mark_max;
- const PERL_CONTEXT *cx_n = NULL;
- const PERL_SI *si_n;
-
- /* there's a separate stack per SI, so only search
- * this one */
-
- for (i=ix+1; i<=si->si_cxix; i++) {
- if (CxTYPE(cx) == CXt_SUBST)
- continue;
- cx_n = &(si->si_cxstack[i]);
- break;
- }
-
- stack_min = cx->blk_oldsp;
-
- if (cx_n) {
- stack_max = cx_n->blk_oldsp;
- }
- else if (si == PL_curstackinfo) {
- stack_max = PL_stack_sp - AvARRAY(si->si_stack);
- }
- else {
- stack_max = AvFILLp(si->si_stack);
- }
-
- /* for the other stack types, there's only one stack
- * shared between all SIs */
-
- si_n = si;
- i = ix;
- cx_n = NULL;
- for (;;) {
- i++;
- if (i > si_n->si_cxix) {
- if (si_n == PL_curstackinfo)
- break;
- else {
- si_n = si_n->si_next;
- i = 0;
- }
- }
- if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
- continue;
- cx_n = &(si_n->si_cxstack[i]);
- break;
- }
-
- mark_min = cx->blk_oldmarksp;
- if (cx_n) {
- mark_max = cx_n->blk_oldmarksp;
- }
- else {
- mark_max = PL_markstack_ptr - PL_markstack;
- }
-
- deb_stack_n(AvARRAY(si->si_stack),
- stack_min, stack_max, mark_min, mark_max);
-
- if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
- || CxTYPE(cx) == CXt_FORMAT)
- {
- const OP * const retop = cx->blk_sub.retop;
-
- PerlIO_printf(Perl_debug_log, " retop=%s\n",
- retop ? OP_NAME(retop) : "(null)"
- );
- }
- }
- } /* next context */
-
-
- if (si == PL_curstackinfo)
- break;
- si = si->si_next;
- si_ix++;
- if (!si)
- break; /* shouldn't happen, but just in case.. */
+ const char * const si_name =
+ si_name_ix < C_ARRAY_LENGTH(si_names) ?
+ si_names[si_name_ix] : "????";
+ I32 ix;
+ PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n",
+ (IV)si_ix, si_name);
+
+ for (ix=0; ix<=si->si_cxix; ix++) {
+
+ const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
+ PerlIO_printf(Perl_debug_log,
+ " CX %" IVdf ": %-6s => ",
+ (IV)ix, PL_block_type[CxTYPE(cx)]
+ );
+ /* substitution contexts don't save stack pointers etc) */
+ if (CxTYPE(cx) == CXt_SUBST)
+ PerlIO_printf(Perl_debug_log, "\n");
+ else {
+
+ /* Find the current context's stack range by searching
+ * forward for any higher contexts using this stack; failing
+ * that, it will be equal to the size of the stack for old
+ * stacks, or PL_stack_sp for the current stack
+ */
+
+ I32 i, stack_min, stack_max, mark_min, mark_max;
+ const PERL_CONTEXT *cx_n = NULL;
+ const PERL_SI *si_n;
+
+ /* there's a separate argument stack per SI, so only
+ * search this one */
+
+ for (i=ix+1; i<=si->si_cxix; i++) {
+ const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]);
+ if (CxTYPE(this_cx) == CXt_SUBST)
+ continue;
+ cx_n = this_cx;
+ break;
+ }
+
+ stack_min = cx->blk_oldsp;
+
+ if (cx_n) {
+ stack_max = cx_n->blk_oldsp;
+ }
+ else if (si == PL_curstackinfo) {
+ stack_max = PL_stack_sp - AvARRAY(si->si_stack);
+ }
+ else {
+ stack_max = AvFILLp(si->si_stack);
+ }
+
+ /* for the markstack, there's only one stack shared
+ * between all SIs */
+
+ si_n = si;
+ i = ix;
+ cx_n = NULL;
+ for (;;) {
+ i++;
+ if (i > si_n->si_cxix) {
+ if (si_n == PL_curstackinfo)
+ break;
+ else {
+ si_n = si_n->si_next;
+ i = 0;
+ }
+ }
+ if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
+ continue;
+ cx_n = &(si_n->si_cxstack[i]);
+ break;
+ }
+
+ mark_min = cx->blk_oldmarksp;
+ if (cx_n) {
+ mark_max = cx_n->blk_oldmarksp;
+ }
+ else {
+ mark_max = PL_markstack_ptr - PL_markstack;
+ }
+
+ deb_stack_n(AvARRAY(si->si_stack),
+ stack_min, stack_max, mark_min, mark_max);
+
+ if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
+ || CxTYPE(cx) == CXt_FORMAT)
+ {
+ const OP * const retop = cx->blk_sub.retop;
+
+ PerlIO_printf(Perl_debug_log, " retop=%s\n",
+ retop ? OP_NAME(retop) : "(null)"
+ );
+ }
+ }
+ } /* next context */
+
+
+ if (si == PL_curstackinfo)
+ break;
+ si = si->si_next;
+ si_ix++;
+ if (!si)
+ break; /* shouldn't happen, but just in case.. */
} /* next stackinfo */
PerlIO_printf(Perl_debug_log, "\n");
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: t
- * End:
- *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff