Have Carp respect CORE::GLOBAL::caller if it exists

[p5sagit/p5-mst-13.2.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index c52a0d6..0730aff 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1675,11 +1675,11 @@ Perl_do_readline(pTHX)
                (void)do_close(PL_last_in_gv, FALSE);
            }
            else if (type == OP_GLOB) {
-               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
-                   Perl_warner(aTHX_ packWARN(WARN_GLOB),
-                          "glob failed (child exited with status %d%s)",
-                          (int)(STATUS_CURRENT >> 8),
-                          (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+               if (!do_close(PL_last_in_gv, FALSE)) {
+                   Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+                                  "glob failed (child exited with status %d%s)",
+                                  (int)(STATUS_CURRENT >> 8),
+                                  (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
                }
            }
            if (gimme == G_SCALAR) {
@@ -1823,16 +1823,11 @@ PP(pp_helem)
        if (localizing) {
            if (HvNAME_get(hv) && isGV(*svp))
                save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
-           else {
-               if (!preeminent) {
-                   STRLEN keylen;
-                   const char * const key = SvPV_const(keysv, keylen);
-                   SAVEDELETE(hv, savepvn(key,keylen),
-                              SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
-               } else
-                   save_helem_flags(hv, keysv, svp,
-                                    (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
-            }
+           else if (preeminent)
+               save_helem_flags(hv, keysv, svp,
+                    (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+           else
+               SAVEHDELETE(hv, keysv);
        }
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
@@ -2705,7 +2700,7 @@ PP(pp_entersub)
            if (!sym)
                DIE(aTHX_ PL_no_usym, "a subroutine");
            if (PL_op->op_private & HINT_STRICT_REFS)
-               DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+               DIE(aTHX_ PL_no_symref, sym, len>32 ? "..." : "", "a subroutine");
            cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
            break;
        }
@@ -2770,7 +2765,7 @@ try_autoload:
             PL_curcopdb = PL_curcop;
          if (CvLVALUE(cv)) {
              /* check for lsub that handles lvalue subroutines */
-            cv = GvCV(gv_HVadd(gv_fetchpv("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+            cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
              /* if lsub not found then fall back to DB::sub */
             if (!cv) cv = GvCV(PL_DBsub);
          } else {
@@ -2874,8 +2869,10 @@ try_autoload:
            PL_curcopdb = NULL;
        }
        /* Do we need to open block here? XXXX */
-       if (CvXSUB(cv)) /* XXX this is supposed to be true */
-           (void)(*CvXSUB(cv))(aTHX_ cv);
+
+       /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+       assert(CvXSUB(cv));
+       CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
 
        /* Enforce some sanity in scalar context. */
        if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
@@ -3044,17 +3041,16 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     SV* ob;
     GV* gv;
     HV* stash;
-    STRLEN namelen;
     const char* packname = NULL;
     SV *packsv = NULL;
     STRLEN packlen;
-    const char * const name = SvPV_const(meth, namelen);
     SV * const sv = *(PL_stack_base + TOPMARK + 1);
 
     PERL_ARGS_ASSERT_METHOD_COMMON;
 
     if (!sv)
-       Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
+       Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
+                  SVfARG(meth));
 
     SvGETMAGIC(sv);
     if (SvROK(sv))
@@ -3083,7 +3079,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
                    : !isIDFIRST(*packname)
                ))
            {
-               Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+               Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
+                          SVfARG(meth),
                           SvOK(sv) ? "without a package or object reference"
                                    : "on an undefined value");
            }
@@ -3108,6 +3105,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
                     && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
                     && SvOBJECT(ob))))
     {
+       const char * const name = SvPV_nolen_const(meth);
        Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
                   (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
                   name);
@@ -3131,7 +3129,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        }
     }
 
-    gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
+    gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
+                             SvPV_nolen_const(meth),
                              GV_AUTOLOAD | GV_CROAK);
 
     assert(gv);