summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNicholas Clark <nick@ccl4.org>2012-01-16 17:08:38 +0100
committerNicholas Clark <nick@ccl4.org>2012-01-16 23:04:12 +0100
commit5637ef5b34a3e8caf72080387a15ea8d81b61baf (patch)
treef96feca3a69260136149ab5dcd6aef6d87ad3be2
parent91a6d79299c498b1b5148f435b9ca88053476607 (diff)
downloadperl-5637ef5b34a3e8caf72080387a15ea8d81b61baf.tar.gz
Provide as much diagnostic information as possible in "panic: ..." messages.
The convention is that when the interpreter dies with an internal error, the message starts "panic: ". Historically, many panic messages had been terse fixed strings, which means that the out-of-range values that triggered the panic are lost. Now we try to report these values, as such panics may not be repeatable, and the original error message may be the only diagnostic we get when we try to find the cause. We can't report diagnostics when the panic message is generated by something other than croak(), as we don't have *printf-style format strings. Don't attempt to report values in panics related to *printf buffer overflows, as attempting to format the values to strings may repeat or compound the original error.
-rw-r--r--cop.h2
-rw-r--r--doio.c3
-rw-r--r--op.c10
-rw-r--r--pad.c12
-rw-r--r--perl.c4
-rw-r--r--pod/perldiag.pod42
-rw-r--r--pp.c2
-rw-r--r--pp_ctl.c7
-rw-r--r--pp_hot.c9
-rw-r--r--pp_pack.c11
-rw-r--r--pp_sys.c2
-rw-r--r--regcomp.c13
-rw-r--r--regexec.c3
-rw-r--r--scope.c4
-rw-r--r--sv.c9
-rw-r--r--toke.c17
-rw-r--r--utf8.c22
-rw-r--r--util.c39
18 files changed, 131 insertions, 80 deletions
diff --git a/cop.h b/cop.h
index 626feee927..c2f7d3417e 100644
--- a/cop.h
+++ b/cop.h
@@ -138,7 +138,7 @@ typedef struct jmpenv JMPENV;
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
if ((v) == 2) \
PerlProc_exit(STATUS_EXIT); \
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env, v=%d\n", (int)v); \
PerlProc_exit(1); \
} STMT_END
diff --git a/doio.c b/doio.c
index 1a031034ac..08a15b71fb 100644
--- a/doio.c
+++ b/doio.c
@@ -149,7 +149,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
int ismodifying;
if (num_svs != 0) {
- Perl_croak(aTHX_ "panic: sysopen with multiple args");
+ Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld",
+ (long) num_svs);
}
/* It's not always
diff --git a/op.c b/op.c
index d4dcf53272..12f0cbc951 100644
--- a/op.c
+++ b/op.c
@@ -837,7 +837,8 @@ Perl_op_contextualize(pTHX_ OP *o, I32 context)
case G_ARRAY: return list(o);
case G_VOID: return scalarvoid(o);
default:
- Perl_croak(aTHX_ "panic: op_contextualize bad context");
+ Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
+ (long) context);
return o;
}
}
@@ -8149,7 +8150,7 @@ Perl_ck_grep(pTHX_ OP *o)
return o;
kid = cLISTOPo->op_first->op_sibling;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_grep");
+ Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
kid = kUNOP->op_first;
if (!gwop)
@@ -8857,7 +8858,7 @@ Perl_ck_split(pTHX_ OP *o)
kid = cLISTOPo->op_first;
if (kid->op_type != OP_NULL)
- Perl_croak(aTHX_ "panic: ck_split");
+ Perl_croak(aTHX_ "panic: ck_split, type=%u", (unsigned) kid->op_type);
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
if (kid)
@@ -9081,7 +9082,8 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
const char *e = NULL;
PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_PROTO;
if (SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
- Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto");
+ Perl_croak(aTHX_ "panic: ck_entersub_args_proto CV with no proto,"
+ "flags=%lx", (unsigned long) SvFLAGS(protosv));
if (SvTYPE(protosv) == SVt_PVCV)
proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
else proto = SvPV(protosv, proto_len);
diff --git a/pad.c b/pad.c
index b67722f48c..779e6d6708 100644
--- a/pad.c
+++ b/pad.c
@@ -669,7 +669,8 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
ASSERT_CURPAD_ACTIVE("pad_alloc");
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_alloc");
+ Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (PL_pad_reset_pending)
pad_reset();
if (tmptype & SVs_PADMY) {
@@ -1513,7 +1514,8 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust)
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_swipe curpad");
+ Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (!po)
Perl_croak(aTHX_ "panic: pad_swipe po");
@@ -1559,7 +1561,8 @@ S_pad_reset(pTHX)
dVAR;
#ifdef USE_BROKEN_PAD_RESET
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_reset curpad");
+ Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
DEBUG_X(PerlIO_printf(Perl_debug_log,
"Pad 0x%"UVxf"[0x%"UVxf"] reset: padix %ld -> %ld",
@@ -1712,7 +1715,8 @@ Perl_pad_free(pTHX_ PADOFFSET po)
if (!PL_curpad)
return;
if (AvARRAY(PL_comppad) != PL_curpad)
- Perl_croak(aTHX_ "panic: pad_free curpad");
+ Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p",
+ AvARRAY(PL_comppad), PL_curpad);
if (!po)
Perl_croak(aTHX_ "panic: pad_free po");
diff --git a/perl.c b/perl.c
index 28795110b8..c8e8bfbc30 100644
--- a/perl.c
+++ b/perl.c
@@ -2330,7 +2330,7 @@ perl_run(pTHXx)
POPSTACK_TO(PL_mainstack);
goto redo_body;
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n");
FREETMPS;
ret = 1;
break;
@@ -4820,7 +4820,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
CopLINE_set(PL_curcop, oldline);
JMPENV_JUMP(3);
}
- PerlIO_printf(Perl_error_log, "panic: restartop\n");
+ PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n");
FREETMPS;
break;
}
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 544a9ed6b4..9263de2989 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3517,15 +3517,15 @@ an ACL related-function, but that function is not available on this
platform. Earlier checks mean that it should not be possible to
enter this branch on this platform.
-=item panic: ck_grep
+=item panic: ck_grep, type=%u
(P) Failed an internal consistency check trying to compile a grep.
-=item panic: ck_split
+=item panic: ck_split, type=%u
(P) Failed an internal consistency check trying to compile a split.
-=item panic: corrupt saved stack index
+=item panic: corrupt saved stack index %ld
(P) The savestack was requested to restore more localized values than
there are in the savestack.
@@ -3559,7 +3559,7 @@ failure was caught.
(P) The library function frexp() failed, making printf("%f") impossible.
-=item panic: goto
+=item panic: goto, type=%u, ix=%ld
(P) We popped the context stack to a context with the specified label,
and then discovered it wasn't a context we know how to do a goto in.
@@ -3571,11 +3571,11 @@ repeatedly, but each time something re-created entries in the glob.
Most likely the glob contains an object with a reference back to
the glob and a destructor that adds a new object to the glob.
-=item panic: INTERPCASEMOD
+=item panic: INTERPCASEMOD, %s
(P) The lexer got into a bad state at a case modifier.
-=item panic: INTERPCONCAT
+=item panic: INTERPCONCAT, %s
(P) The lexer got into a bad state parsing a string with brackets.
@@ -3583,7 +3583,7 @@ the glob and a destructor that adds a new object to the glob.
(F) forked child returned an incomprehensible message about its errno.
-=item panic: last
+=item panic: last, type=%u
(P) We popped the context stack to a block context, and then discovered
it wasn't a block context.
@@ -3593,7 +3593,7 @@ it wasn't a block context.
(P) A writable lexical variable became read-only somehow within the
scope.
-=item panic: leave_scope inconsistency
+=item panic: leave_scope inconsistency %u
(P) The savestack probably got out of sync. At least, there was an
invalid enum on the top of it.
@@ -3603,7 +3603,7 @@ invalid enum on the top of it.
(P) Failed an internal consistency check while trying to reset all weak
references to an object.
-=item panic: malloc
+=item panic: malloc, %s
(P) Something requested a negative number of bytes of malloc.
@@ -3611,12 +3611,12 @@ references to an object.
(P) Something tried to allocate more memory than possible.
-=item panic: pad_alloc
+=item panic: pad_alloc, %p!=%p
(P) The compiler got confused about which scratch pad it was allocating
and freeing temporaries and lexicals from.
-=item panic: pad_free curpad
+=item panic: pad_free curpad, %p!=%p
(P) The compiler got confused about which scratch pad it was allocating
and freeing temporaries and lexicals from.
@@ -3625,7 +3625,7 @@ and freeing temporaries and lexicals from.
(P) An invalid scratch pad offset was detected internally.
-=item panic: pad_reset curpad
+=item panic: pad_reset curpad, %p!=%p
(P) The compiler got confused about which scratch pad it was allocating
and freeing temporaries and lexicals from.
@@ -3634,7 +3634,7 @@ and freeing temporaries and lexicals from.
(P) An invalid scratch pad offset was detected internally.
-=item panic: pad_swipe curpad
+=item panic: pad_swipe curpad, %p!=%p
(P) The compiler got confused about which scratch pad it was allocating
and freeing temporaries and lexicals from.
@@ -3643,7 +3643,7 @@ and freeing temporaries and lexicals from.
(P) An invalid scratch pad offset was detected internally.
-=item panic: pp_iter
+=item panic: pp_iter, type=%u
(P) The foreach iterator got called in a non-loop context frame.
@@ -3652,11 +3652,11 @@ and freeing temporaries and lexicals from.
(P) The internal pp_match() routine was called with invalid operational
data.
-=item panic: pp_split
+=item panic: pp_split, pm=%p, s=%p
(P) Something terrible went wrong in setting up for the split.
-=item panic: realloc
+=item panic: realloc, %s
(P) Something requested a negative number of bytes of realloc.
@@ -3665,17 +3665,17 @@ data.
(P) The internal sv_replace() function was handed a new SV with a
reference count other than 1.
-=item panic: restartop
+=item panic: restartop in %s
(P) Some internal routine requested a goto (or something like it), and
didn't supply the destination.
-=item panic: return
+=item panic: return, type=%u
(P) We popped the context stack to a subroutine or eval context, and
then discovered it wasn't a subroutine or eval context.
-=item panic: scan_num
+=item panic: scan_num, %s
(P) scan_num() got called on something that wasn't a number.
@@ -3684,7 +3684,7 @@ then discovered it wasn't a subroutine or eval context.
(P) The sv_chop() routine was passed a position that is not within the
scalar's string buffer.
-=item panic: sv_insert
+=item panic: sv_insert, midend=%p, bigend=%p
(P) The sv_insert() routine was told to remove more string than there
was string.
@@ -3714,7 +3714,7 @@ to even) byte length.
(P) Something tried to call utf16_to_utf8_reversed with an odd (as opposed
to even) byte length.
-=item panic: yylex
+=item panic: yylex, %s
(P) The lexer got into a bad state while processing a case modifier.
diff --git a/pp.c b/pp.c
index eaf6a85277..b54b3abc8b 100644
--- a/pp.c
+++ b/pp.c
@@ -5225,7 +5225,7 @@ PP(pp_split)
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE(aTHX_ "panic: pp_split");
+ DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
diff --git a/pp_ctl.c b/pp_ctl.c
index ce349bd2fe..038eae0810 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2487,7 +2487,7 @@ PP(pp_return)
retop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: return");
+ DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
@@ -2634,7 +2634,7 @@ PP(pp_last)
nextop = cx->blk_sub.retop;
break;
default:
- DIE(aTHX_ "panic: last");
+ DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
}
TAINT_NOT;
@@ -3058,7 +3058,8 @@ PP(pp_goto)
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
default:
if (ix)
- DIE(aTHX_ "panic: goto");
+ DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
+ CxTYPE(cx), (long) ix);
gotoprobe = PL_main_root;
break;
}
diff --git a/pp_hot.c b/pp_hot.c
index a66a690608..f63164012a 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1390,7 +1390,10 @@ PP(pp_match)
s = RX_OFFS(rx)[i].start + truebase;
if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
len < 0 || len > strend - s)
- DIE(aTHX_ "panic: pp_match start/end pointers");
+ DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
+ "start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
+ (long) i, (long) RX_OFFS(rx)[i].start,
+ (long)RX_OFFS(rx)[i].end, s, strend, (UV) len);
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
@@ -1841,7 +1844,7 @@ PP(pp_iter)
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
if (!CxTYPE_is_LOOP(cx))
- DIE(aTHX_ "panic: pp_iter");
+ DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
itersvp = CxITERVAR(cx);
if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
@@ -2119,7 +2122,7 @@ PP(pp_subst)
force_it:
if (!pm || !s)
- DIE(aTHX_ "panic: pp_subst");
+ DIE(aTHX_ "panic: pp_subst, pm=%p, s=%p", pm, s);
strend = s + len;
slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
diff --git a/pp_pack.c b/pp_pack.c
index c62754f86d..273908cf98 100644
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2455,7 +2455,8 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) {
if (m != marks + sym_ptr->level+1) {
Safefree(marks);
Safefree(to_start);
- Perl_croak(aTHX_ "panic: marks beyond string end");
+ Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, "
+ "level=%d", m, marks, sym_ptr->level);
}
for (group=sym_ptr; group; group = group->previous)
group->strbeg = marks[group->level] - to_start;
@@ -2789,7 +2790,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
GROWING(0, cat, start, cur, len);
if (!uni_to_bytes(aTHX_ &aptr, end, cur, fromlen,
datumtype | TYPE_IS_PACK))
- Perl_croak(aTHX_ "panic: predicted utf8 length not available");
+ Perl_croak(aTHX_ "panic: predicted utf8 length not available, "
+ "for '%c', aptr=%p end=%p cur=%p, fromlen=%"UVuf,
+ (int)datumtype, aptr, end, cur, (UV)fromlen);
cur += fromlen;
len -= fromlen;
} else if (utf8) {
@@ -3584,7 +3587,9 @@ extern const double _double_constants[];
'u' | TYPE_IS_PACK)) {
*cur = '\0';
SvCUR_set(cat, cur - start);
- Perl_croak(aTHX_ "panic: string is shorter than advertised");
+ Perl_croak(aTHX_ "panic: string is shorter than advertised, "
+ "aptr=%p, aend=%p, buffer=%p, todo=%ld",
+ aptr, aend, buffer, (long) todo);
}
end = doencodes(hunk, buffer, todo);
} else {
diff --git a/pp_sys.c b/pp_sys.c
index d22c578754..c8049586dc 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -4198,7 +4198,7 @@ PP(pp_system)
PerlLIO_close(pp[0]);
if (n) { /* Error */
if (n != sizeof(int))
- DIE(aTHX_ "panic: kid popen errno read");
+ DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
errno = errkid; /* Propagate errno from kid */
STATUS_NATIVE_CHILD_SET(-1);
}
diff --git a/regcomp.c b/regcomp.c
index 6e7bb3e272..c8a6e96df0 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -5778,7 +5778,8 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
return sv_dat;
}
else {
- Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
+ Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
+ (unsigned long) flags);
}
/* NOT REACHED */
}
@@ -6093,7 +6094,9 @@ Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV
if (array[final_element] > start
|| ELEMENT_RANGE_MATCHES_INVLIST(final_element))
{
- Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
+ Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%"UVuf", start=%"UVuf", match=%c",
+ array[final_element], start,
+ ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
}
/* Here, it is a legal append. If the new range begins with the first
@@ -11354,7 +11357,8 @@ S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
return(ret);
}
if (RExC_emit >= RExC_emit_bound)
- Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
+ Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
+ op, RExC_emit, RExC_emit_bound);
NODE_ALIGN_FILL(ret);
ptr = ret;
@@ -11409,7 +11413,8 @@ S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
return(ret);
}
if (RExC_emit >= RExC_emit_bound)
- Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
+ Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
+ op, RExC_emit, RExC_emit_bound);
NODE_ALIGN_FILL(ret);
ptr = ret;
diff --git a/regexec.c b/regexec.c
index 1bb0ceaedf..5eb6a2b6bb 100644
--- a/regexec.c
+++ b/regexec.c
@@ -353,7 +353,8 @@ S_regcppush(pTHX_ I32 parenfloor)
GET_RE_DEBUG_FLAGS_DECL;
if (paren_elems_to_push < 0)
- Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
+ Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0",
+ paren_elems_to_push);
if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
diff --git a/scope.c b/scope.c
index fbd92a9e1d..cc207c089c 100644
--- a/scope.c
+++ b/scope.c
@@ -714,7 +714,7 @@ Perl_leave_scope(pTHX_ I32 base)
bool was = PL_tainted;
if (base < -1)
- Perl_croak(aTHX_ "panic: corrupt saved stack index");
+ Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
(long)PL_savestack_ix, (long)base));
while (PL_savestack_ix > base) {
@@ -1160,7 +1160,7 @@ Perl_leave_scope(pTHX_ I32 base)
parser_free((yy_parser *) ptr);
break;
default:
- Perl_croak(aTHX_ "panic: leave_scope inconsistency");
+ Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type);
}
}
diff --git a/sv.c b/sv.c
index 1fc5459891..dff16078b4 100644
--- a/sv.c
+++ b/sv.c
@@ -4478,7 +4478,8 @@ Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, regi
/* len is STRLEN which is unsigned, need to copy to signed */
const IV iv = len;
if (iv < 0)
- Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
+ Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
+ IVdf, iv);
}
SvUPGRADE(sv, SVt_PV);
@@ -5793,7 +5794,8 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l
bigend = big + SvCUR(bigstr);
if (midend > bigend)
- Perl_croak(aTHX_ "panic: sv_insert");
+ Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
+ midend, bigend);
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
@@ -7076,7 +7078,8 @@ Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
s = (const U8*)SvPV_const(sv, blen);
if (blen < byte)
- Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
+ ", byte=%"UVuf, (UV)blen, (UV)byte);
send = s + byte;
diff --git a/toke.c b/toke.c
index fa4c9c95ca..baa21d602b 100644
--- a/toke.c
+++ b/toke.c
@@ -3509,7 +3509,8 @@ S_scan_const(pTHX_ char *start)
*d = '\0';
SvCUR_set(sv, d - SvPVX_const(sv));
if (SvCUR(sv) >= SvLEN(sv))
- Perl_croak(aTHX_ "panic: constant overflowed allocated space");
+ Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
+ " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
SvPOK_on(sv);
if (PL_encoding && !has_utf8) {
@@ -4476,7 +4477,9 @@ Perl_yylex(pTHX)
case LEX_INTERPCASEMOD:
#ifdef DEBUGGING
if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
- Perl_croak(aTHX_ "panic: INTERPCASEMOD");
+ Perl_croak(aTHX_
+ "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
+ PL_bufptr, PL_bufend, *PL_bufptr);
#endif
/* handle \E or end of string */
if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
@@ -4562,7 +4565,7 @@ Perl_yylex(pTHX)
else if (*s == 'Q')
NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
else
- Perl_croak(aTHX_ "panic: yylex");
+ Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
if (PL_madskills) {
SV* const tmpsv = newSVpvs("\\ ");
/* replace the space with the character we want to escape
@@ -4669,7 +4672,8 @@ Perl_yylex(pTHX)
case LEX_INTERPCONCAT:
#ifdef DEBUGGING
if (PL_lex_brackets)
- Perl_croak(aTHX_ "panic: INTERPCONCAT");
+ Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+ (long) PL_lex_brackets);
#endif
if (PL_bufptr == PL_bufend)
return REPORT(sublex_done());
@@ -5156,7 +5160,8 @@ Perl_yylex(pTHX)
if (d < PL_bufend)
d++;
else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
- Perl_croak(aTHX_ "panic: input overflow");
+ Perl_croak(aTHX_ "panic: input overflow, %p > %p",
+ d, PL_bufend);
#ifdef PERL_MAD
if (PL_madskills)
PL_thiswhite = newSVpvn(s, d - s);
@@ -10180,7 +10185,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
switch (*s) {
default:
- Perl_croak(aTHX_ "panic: scan_num");
+ Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
/* if it starts with a 0, it could be an octal number, a decimal in
0.13 disguise, or a hexadecimal number, or a binary number. */
diff --git a/utf8.c b/utf8.c
index 5768f66183..0014521a84 100644
--- a/utf8.c
+++ b/utf8.c
@@ -2775,7 +2775,9 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
if (!svp || !(tmps = (U8*)SvPV(*svp, slen))
|| (slen << 3) < needents)
- Perl_croak(aTHX_ "panic: swash_fetch got improper swatch");
+ Perl_croak(aTHX_ "panic: swash_fetch got improper swatch, "
+ "svp=%p, tmps=%p, slen=%"UVuf", needents=%"UVuf,
+ svp, tmps, (UV)slen, (UV)needents);
}
PL_last_swash_hv = hv;
@@ -2820,7 +2822,8 @@ Perl_swash_fetch(pTHX_ SV *swash, const U8 *ptr, bool do_utf8)
off <<= 2;
return (tmps[off] << 24) + (tmps[off+1] << 16) + (tmps[off+2] << 8) + tmps[off + 3] ;
}
- Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width");
+ Perl_croak(aTHX_ "panic: swash_fetch got swatch of unexpected bit width, "
+ "slen=%"UVuf", needents=%"UVuf, (UV)slen, (UV)needents);
NORETURN_FUNCTION_END;
}
@@ -3153,7 +3156,8 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
otherbitssvp = hv_fetchs(otherhv, "BITS", FALSE);
otherbits = (STRLEN)SvUV(*otherbitssvp);
if (bits < otherbits)
- Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch");
+ Perl_croak(aTHX_ "panic: swatch_get found swatch size mismatch, "
+ "bits=%"UVuf", otherbits=%"UVuf, (UV)bits, (UV)otherbits);
/* The "other" swatch must be destroyed after. */
other = swatch_get(*othersvp, start, span);
@@ -3165,7 +3169,9 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
s = (U8*)SvPV(swatch, slen);
if (bits == 1 && otherbits == 1) {
if (slen != olen)
- Perl_croak(aTHX_ "panic: swatch_get found swatch length mismatch");
+ Perl_croak(aTHX_ "panic: swatch_get found swatch length "
+ "mismatch, slen=%"UVuf", olen=%"UVuf,
+ (UV)slen, (UV)olen);
switch (opc) {
case '+':
@@ -3330,7 +3336,9 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
while ((sv_to = hv_iternextsv(specials_hv, &char_from, &from_len))) {
SV** listp;
if (! SvPOK(sv_to)) {
- Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() unexpectedly is not a string");
+ Perl_croak(aTHX_ "panic: value returned from hv_iternextsv() "
+ "unexpectedly is not a string, flags=%lu",
+ (unsigned long)SvFLAGS(sv_to));
}
/*DEBUG_U(PerlIO_printf(Perl_debug_log, "Found mapping from %"UVXf", First char of to is %"UVXf"\n", utf8_to_uvchr((U8*) char_from, 0), utf8_to_uvchr((U8*) SvPVX(sv_to), 0)));*/
@@ -3638,7 +3646,9 @@ Perl__swash_to_invlist(pTHX_ SV* const swash)
otherbits = (STRLEN)SvUV(*otherbitssvp);
if (bits != otherbits || bits != 1) {
- Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean properties");
+ Perl_croak(aTHX_ "panic: _swash_to_invlist only operates on boolean "
+ "properties, bits=%"UVuf", otherbits=%"UVuf,
+ (UV)bits, (UV)otherbits);
}
/* The "other" swatch must be destroyed after. */
diff --git a/util.c b/util.c
index bdfdfdc30b..7ab0df70f3 100644
--- a/util.c
+++ b/util.c
@@ -95,7 +95,7 @@ Perl_safesysmalloc(MEM_SIZE size)
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc");
+ Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
#endif
ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
PERL_ALLOC_CHECK(ptr);
@@ -172,7 +172,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool");
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
assert(header->next->prev == header);
assert(header->prev->next == header);
@@ -188,7 +189,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc");
+ Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
@@ -258,14 +259,19 @@ Perl_safesysfree(Malloc_t where)
= (struct perl_memory_debug_header *)where;
if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: free from wrong pool");
+ Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
}
if (!header->prev) {
Perl_croak_nocontext("panic: duplicate free");
}
- if (!(header->next) || header->next->prev != header
- || header->prev->next != header) {
- Perl_croak_nocontext("panic: bad free");
+ if (!(header->next))
+ Perl_croak_nocontext("panic: bad free, header->next==NULL");
+ if (header->next->prev != header || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+ "header=%p, ->prev->next=%p",
+ header->next->prev, header,
+ header->prev->next);
}
/* Unlink us from the chain. */
header->next->prev = header->prev;
@@ -317,7 +323,8 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc");
+ Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ (UV)size, (UV)count);
#endif
#ifdef PERL_TRACK_MEMPOOL
/* Have to use malloc() because we've added some space for our tracking
@@ -2735,7 +2742,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
@@ -2894,7 +2901,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
int pid2, status;
PerlLIO_close(p[This]);
if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read");
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
@@ -3705,8 +3712,9 @@ Perl_get_context(void)
#if defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
- if (pthread_getspecific(PL_thr_key, &t))
- Perl_croak_nocontext("panic: pthread_getspecific");
+ int error = pthread_getspecific(PL_thr_key, &t)
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
# else
# ifdef I_MACH_CTHREADS
@@ -3729,8 +3737,11 @@ Perl_set_context(void *t)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
- if (pthread_setspecific(PL_thr_key, t))
- Perl_croak_nocontext("panic: pthread_setspecific");
+ {
+ const int error = pthread_setspecific(PL_thr_key, t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+ }
# endif
#else
PERL_UNUSED_ARG(t);