(perl #134266) make sure $@ is writable when we write to it

when unwinding.

Since except_sv might be ERRSV we try to preserve it's value,
if not the actual SV (which we have an extra refcount on if it is
except_sv).

diff --git a/perl.h b/perl.h
index b47587c..443534a 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1380,6 +1380,13 @@ Clear the contents of C<$@>, setting it to the empty string.
 
 This replaces any read-only SV with a fresh SV and removes any magic.
 
+=for apidoc Am|void|SANE_ERRSV
+
+Clean up ERRSV so we can safely set it.
+
+This replaces any read-only SV with a fresh writable copy and removes
+any magic.
+
 =cut
 */
 
@@ -1403,6 +1410,23 @@ This replaces any read-only SV with a fresh SV and removes any magic.
     }                                                                  \
     } STMT_END
 
+/* contains inlined gv_add_by_type */
+#define SANE_ERRSV() STMT_START {                                      \
+    SV ** const svp = &GvSV(PL_errgv);                                 \
+    if (!*svp) {                                                       \
+        *svp = newSVpvs("");                                            \
+    } else if (SvREADONLY(*svp)) {                                     \
+        SV *dupsv = newSVsv(*svp);                                     \
+       SvREFCNT_dec_NN(*svp);                                          \
+       *svp = dupsv;                                                   \
+    } else {                                                           \
+       SV *const errsv = *svp;                                         \
+       if (SvMAGICAL(errsv)) {                                         \
+           mg_free(errsv);                                             \
+       }                                                               \
+    }                                                                  \
+    } STMT_END
+
 
 #ifdef PERL_CORE
 # define DEFSV (0 + GvSVn(PL_defgv))

diff --git a/pp_ctl.c b/pp_ctl.c
index 6fedac3..8d3097b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1724,9 +1724,13 @@ Perl_die_unwind(pTHX_ SV *msv)
         * perls 5.13.{1..7} which had late setting of $@ without this
         * early-setting hack.
         */
-       if (!(in_eval & EVAL_KEEPERR))
+       if (!(in_eval & EVAL_KEEPERR)) {
+            /* remove any read-only/magic from the SV, so we don't
+               get infinite recursion when setting ERRSV */
+            SANE_ERRSV();
            sv_setsv_flags(ERRSV, exceptsv,
                         (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
+        }
 
        if (in_eval & EVAL_KEEPERR) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
@@ -1788,8 +1792,10 @@ Perl_die_unwind(pTHX_ SV *msv)
              */
             S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
 
-           if (!(in_eval & EVAL_KEEPERR))
+           if (!(in_eval & EVAL_KEEPERR)) {
+                SANE_ERRSV();
                sv_setsv(ERRSV, exceptsv);
+            }
            PL_restartjmpenv = restartjmpenv;
            PL_restartop = restartop;
            JMPENV_JUMP(3);

diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
index b1e754c..de0221b 100644 (file)
--- a/t/lib/croak/pp_ctl
+++ b/t/lib/croak/pp_ctl
@@ -51,3 +51,11 @@ use 5.01;
 default{}
 EXPECT
 Can't "default" outside a topicalizer at - line 2.
+########
+# NAME croak with read only $@
+eval '"a" =~ /${*@=\_})/';
+die;
+# this would previously recurse infinitely in the eval
+EXPECT
+Unmatched ) in regex; marked by <-- HERE in m/_) <-- HERE / at (eval 1) line 1.
+       ...propagated at - line 2.