perl/perl-5.24.0-crash-on-explicit-return-from-s-e.patch

95 lines
2.3 KiB
Diff

From 2c639acf40b4abc2783352f8e20dbfb68389e633 Mon Sep 17 00:00:00 2001
From: David Mitchell <davem@iabyn.com>
Date: Mon, 28 Nov 2016 08:03:49 +0000
Subject: [PATCH] crash on explicit return from s///e
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Petr Pisar: Ported to 5.24.0:
commit 7332835e5da7b7a793ef814a84e53003be1d0138
Author: David Mitchell <davem@iabyn.com>
Date: Mon Nov 28 08:03:49 2016 +0000
crash on explicit return from s///e
RT #130188
In
sub f {
my $x = 'a';
$x =~ s/./return;/e;
}
the 'return' triggers popping any contexts above the subroutine context:
in this case, a CXt_SUBST context. In this case, Perl_dounwind() calls
cx_popblock() for the bottom-most popped context, to restore any saved
vars. However, CXt_SUBST is the one context type which *doesn't* use
'struct block' as part of its context struct union, so you can't
cx_popblock() a CXt_SUBST context.
This commit makes it skip the cx_popblock() in this case.
Bug was introduced by me with v5.23.7-235-gfc6e609.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
pp_ctl.c | 6 ++++++
t/re/subst.t | 17 ++++++++++++++++-
2 files changed, 22 insertions(+), 1 deletion(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index 99ff59a..b94c09a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1529,6 +1529,12 @@ Perl_dounwind(pTHX_ I32 cxix)
switch (CxTYPE(cx)) {
case CXt_SUBST:
CX_POPSUBST(cx);
+ /* CXt_SUBST is not a block context type, so skip the
+ * cx_popblock(cx) below */
+ if (cxstack_ix == cxix + 1) {
+ cxstack_ix--;
+ return;
+ }
break;
case CXt_SUB:
cx_popsub(cx);
diff --git a/t/re/subst.t b/t/re/subst.t
index 26a78c7..c039cc4 100644
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -11,7 +11,7 @@ BEGIN {
require './loc_tools.pl';
}
-plan( tests => 270 );
+plan( tests => 271 );
$_ = 'david';
$a = s/david/rules/r;
@@ -1102,3 +1102,18 @@ SKIP: {
$s =~ s/..\G//g;
is($s, "\x{123}", "#RT 126260 gofs");
}
+
+# [perl #130188] crash on return from substitution in subroutine
+# make sure returning from s///e doesn't SEGV
+{
+ my $f = sub {
+ my $x = 'a';
+ $x =~ s/./return;/e;
+ };
+ my $x = $f->();
+ pass("RT #130188");
+}
+
+
+
+
--
2.7.4