|
 |
04bfb0 |
From 3f8dbf40138bd2bcb569b23c88888a41ede9c355 Mon Sep 17 00:00:00 2001
|
|
|
04bfb0 |
From: Tony Cook <tony@develop-help.com>
|
|
|
04bfb0 |
Date: Mon, 5 Aug 2019 15:23:45 +1000
|
|
|
04bfb0 |
Subject: [PATCH] (perl #134266) make sure $@ is writable when we write to it
|
|
|
04bfb0 |
MIME-Version: 1.0
|
|
|
04bfb0 |
Content-Type: text/plain; charset=UTF-8
|
|
|
04bfb0 |
Content-Transfer-Encoding: 8bit
|
|
|
04bfb0 |
|
|
|
04bfb0 |
when unwinding.
|
|
|
04bfb0 |
|
|
|
04bfb0 |
Since except_sv might be ERRSV we try to preserve it's value,
|
|
|
04bfb0 |
if not the actual SV (which we have an extra refcount on if it is
|
|
|
04bfb0 |
except_sv).
|
|
|
04bfb0 |
|
|
|
04bfb0 |
Petr Písař: Ported to 5.30.0 from
|
|
|
04bfb0 |
933e3e630076d4fdbe32a101eeb5f12e37ec4ac2.
|
|
|
04bfb0 |
|
|
|
04bfb0 |
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
|
04bfb0 |
---
|
|
|
04bfb0 |
perl.h | 17 +++++++++++++++++
|
|
|
04bfb0 |
pp_ctl.c | 10 ++++++++--
|
|
|
04bfb0 |
t/lib/croak/pp_ctl | 8 ++++++++
|
|
|
04bfb0 |
3 files changed, 33 insertions(+), 2 deletions(-)
|
|
|
04bfb0 |
|
|
|
04bfb0 |
diff --git a/perl.h b/perl.h
|
|
|
04bfb0 |
index e5a5585..383487c 100644
|
|
|
04bfb0 |
--- a/perl.h
|
|
|
04bfb0 |
+++ b/perl.h
|
|
|
04bfb0 |
@@ -1357,6 +1357,23 @@ EXTERN_C char *crypt(const char *, const char *);
|
|
|
04bfb0 |
} \
|
|
|
04bfb0 |
} STMT_END
|
|
|
04bfb0 |
|
|
|
04bfb0 |
+/* contains inlined gv_add_by_type */
|
|
|
04bfb0 |
+#define SANE_ERRSV() STMT_START { \
|
|
|
04bfb0 |
+ SV ** const svp = &GvSV(PL_errgv); \
|
|
|
04bfb0 |
+ if (!*svp) { \
|
|
|
04bfb0 |
+ *svp = newSVpvs(""); \
|
|
|
04bfb0 |
+ } else if (SvREADONLY(*svp)) { \
|
|
|
04bfb0 |
+ SV *dupsv = newSVsv(*svp); \
|
|
|
04bfb0 |
+ SvREFCNT_dec_NN(*svp); \
|
|
|
04bfb0 |
+ *svp = dupsv; \
|
|
|
04bfb0 |
+ } else { \
|
|
|
04bfb0 |
+ SV *const errsv = *svp; \
|
|
|
04bfb0 |
+ if (SvMAGICAL(errsv)) { \
|
|
|
04bfb0 |
+ mg_free(errsv); \
|
|
|
04bfb0 |
+ } \
|
|
|
04bfb0 |
+ } \
|
|
|
04bfb0 |
+ } STMT_END
|
|
|
04bfb0 |
+
|
|
|
04bfb0 |
|
|
|
04bfb0 |
#ifdef PERL_CORE
|
|
|
04bfb0 |
# define DEFSV (0 + GvSVn(PL_defgv))
|
|
|
04bfb0 |
diff --git a/pp_ctl.c b/pp_ctl.c
|
|
|
04bfb0 |
index a38b9c1..1f2d812 100644
|
|
|
04bfb0 |
--- a/pp_ctl.c
|
|
|
04bfb0 |
+++ b/pp_ctl.c
|
|
|
04bfb0 |
@@ -1720,9 +1720,13 @@ Perl_die_unwind(pTHX_ SV *msv)
|
|
|
04bfb0 |
* perls 5.13.{1..7} which had late setting of $@ without this
|
|
|
04bfb0 |
* early-setting hack.
|
|
|
04bfb0 |
*/
|
|
|
04bfb0 |
- if (!(in_eval & EVAL_KEEPERR))
|
|
|
04bfb0 |
+ if (!(in_eval & EVAL_KEEPERR)) {
|
|
|
04bfb0 |
+ /* remove any read-only/magic from the SV, so we don't
|
|
|
04bfb0 |
+ get infinite recursion when setting ERRSV */
|
|
|
04bfb0 |
+ SANE_ERRSV();
|
|
|
04bfb0 |
sv_setsv_flags(ERRSV, exceptsv,
|
|
|
04bfb0 |
(SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
|
|
|
04bfb0 |
+ }
|
|
|
04bfb0 |
|
|
|
04bfb0 |
if (in_eval & EVAL_KEEPERR) {
|
|
|
04bfb0 |
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
|
|
|
04bfb0 |
@@ -1784,8 +1788,10 @@ Perl_die_unwind(pTHX_ SV *msv)
|
|
|
04bfb0 |
*/
|
|
|
04bfb0 |
S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
|
|
|
04bfb0 |
|
|
|
04bfb0 |
- if (!(in_eval & EVAL_KEEPERR))
|
|
|
04bfb0 |
+ if (!(in_eval & EVAL_KEEPERR)) {
|
|
|
04bfb0 |
+ SANE_ERRSV();
|
|
|
04bfb0 |
sv_setsv(ERRSV, exceptsv);
|
|
|
04bfb0 |
+ }
|
|
|
04bfb0 |
PL_restartjmpenv = restartjmpenv;
|
|
|
04bfb0 |
PL_restartop = restartop;
|
|
|
04bfb0 |
JMPENV_JUMP(3);
|
|
|
04bfb0 |
diff --git a/t/lib/croak/pp_ctl b/t/lib/croak/pp_ctl
|
|
|
04bfb0 |
index b1e754c..de0221b 100644
|
|
|
04bfb0 |
--- a/t/lib/croak/pp_ctl
|
|
|
04bfb0 |
+++ b/t/lib/croak/pp_ctl
|
|
|
04bfb0 |
@@ -51,3 +51,11 @@ use 5.01;
|
|
|
04bfb0 |
default{}
|
|
|
04bfb0 |
EXPECT
|
|
|
04bfb0 |
Can't "default" outside a topicalizer at - line 2.
|
|
|
04bfb0 |
+########
|
|
|
04bfb0 |
+# NAME croak with read only $@
|
|
|
04bfb0 |
+eval '"a" =~ /${*@=\_})/';
|
|
|
04bfb0 |
+die;
|
|
|
04bfb0 |
+# this would previously recurse infinitely in the eval
|
|
|
04bfb0 |
+EXPECT
|
|
|
04bfb0 |
+Unmatched ) in regex; marked by <-- HERE in m/_) <-- HERE / at (eval 1) line 1.
|
|
|
04bfb0 |
+ ...propagated at - line 2.
|
|
|
04bfb0 |
--
|
|
|
04bfb0 |
2.21.0
|
|
|
04bfb0 |
|