From 5637ef5b34a3e8caf72080387a15ea8d81b61baf Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Mon, 16 Jan 2012 17:08:38 +0100 Subject: [PATCH] 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. --- cop.h | 2 +- doio.c | 3 ++- op.c | 10 ++++++---- pad.c | 12 ++++++++---- perl.c | 4 ++-- pod/perldiag.pod | 42 +++++++++++++++++++++--------------------- pp.c | 2 +- pp_ctl.c | 7 ++++--- pp_hot.c | 9 ++++++--- pp_pack.c | 11 ++++++++--- pp_sys.c | 2 +- regcomp.c | 13 +++++++++---- regexec.c | 3 ++- scope.c | 4 ++-- sv.c | 9 ++++++--- toke.c | 17 +++++++++++------ utf8.c | 22 ++++++++++++++++------ util.c | 39 +++++++++++++++++++++++++-------------- 18 files changed, 131 insertions(+), 80 deletions(-) diff --git a/cop.h b/cop.h index 626feee..c2f7d34 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 1a03103..08a15b7 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 d4dcf53..12f0cbc 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 b67722f..779e6d6 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 2879511..c8e8bfb 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 544a9ed..9263de2 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 eaf6a85..b54b3ab 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 ce349bd..038eae0 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 a66a690..f631640 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 c62754f..273908c 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 d22c578..c804958 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 6e7bb3e..c8a6e96 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 1bb0cea..5eb6a2b 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 fbd92a9..cc207c0 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 1fc5459..dff1607 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 fa4c9c9..baa21d6 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 5768f66..0014521 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 bdfdfdc..7ab0df7 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); -- 1.8.3.1