Fix select called with a repeated magical variable

perl-5.27.1-perl-131645-Fix-assert-fail-in-pp_sselect.patch

@@ -0,0 +1,126 @@
+From e26c6904d9f9f5ea818e590331b14038279332d1 Mon Sep 17 00:00:00 2001
+From: Father Chrysostomos <sprout@cpan.org>
+Date: Sun, 25 Jun 2017 06:37:19 -0700
+Subject: [PATCH] [perl #131645] Fix assert fail in pp_sselect
+MIME-Version: 1.0
+Content-Type: text/plain; charset=UTF-8
+Content-Transfer-Encoding: 8bit
+
+pp_sselect (4-arg select) process its first three bitfield arguments
+first, making sure each one has a valid PV, and then it moves on to
+the final, timeout argument.
+
+SvGETMAGIC() on the timeout argument will wipe out any values the SV
+holds, so if the same scalar is used as a bitfield argument *and* as
+the timeout, it will no longer hold a valid PV.
+
+Assertions later in pp_sselect make sure there is a valid PV.
+
+This commit solves the assertion failure by making a temporary copy of
+any gmagical or overloaded argument.  When the temporary copy is made,
+the values written to the temporary copies of the bitfield arguments
+are then copied back to the original magical arguments.
+
+Signed-off-by: Petr Písař <ppisar@redhat.com>
+---
+ pp_sys.c       | 21 +++++++++++++++------
+ t/op/sselect.t | 11 ++++++++++-
+ 2 files changed, 25 insertions(+), 7 deletions(-)
+
+diff --git a/pp_sys.c b/pp_sys.c
+index 65900fa..100762c 100644
+--- a/pp_sys.c
++++ b/pp_sys.c
+@@ -1149,6 +1149,7 @@ PP(pp_sselect)
+     struct timeval *tbuf = &timebuf;
+     I32 growsize;
+     char *fd_sets[4];
++    SV *svs[4];
+ #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ 	I32 masksize;
+ 	I32 offset;
+@@ -1164,7 +1165,7 @@ PP(pp_sselect)
+ 
+     SP -= 4;
+     for (i = 1; i <= 3; i++) {
+-	SV * const sv = SP[i];
++	SV * const sv = svs[i] = SP[i];
+ 	SvGETMAGIC(sv);
+ 	if (!SvOK(sv))
+ 	    continue;
+@@ -1177,9 +1178,14 @@ PP(pp_sselect)
+ 	    if (!SvPOKp(sv))
+ 		Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ 				    "Non-string passed as bitmask");
+-	    SvPV_force_nomg_nolen(sv);	/* force string conversion */
++	    if (SvGAMAGIC(sv)) {
++		svs[i] = sv_newmortal();
++		sv_copypv_nomg(svs[i], sv);
++	    }
++	    else
++		SvPV_force_nomg_nolen(sv); /* force string conversion */
+ 	}
+-	j = SvCUR(sv);
++	j = SvCUR(svs[i]);
+ 	if (maxlen < j)
+ 	    maxlen = j;
+     }
+@@ -1228,7 +1234,7 @@ PP(pp_sselect)
+ 	tbuf = NULL;
+ 
+     for (i = 1; i <= 3; i++) {
+-	sv = SP[i];
++	sv = svs[i];
+ 	if (!SvOK(sv) || SvCUR(sv) == 0) {
+ 	    fd_sets[i] = 0;
+ 	    continue;
+@@ -1275,7 +1281,7 @@ PP(pp_sselect)
+ #endif
+     for (i = 1; i <= 3; i++) {
+ 	if (fd_sets[i]) {
+-	    sv = SP[i];
++	    sv = svs[i];
+ #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
+ 	    s = SvPVX(sv);
+ 	    for (offset = 0; offset < growsize; offset += masksize) {
+@@ -1284,7 +1290,10 @@ PP(pp_sselect)
+ 	    }
+ 	    Safefree(fd_sets[i]);
+ #endif
+-	    SvSETMAGIC(sv);
++	    if (sv != SP[i])
++		SvSetMagicSV(SP[i], sv);
++	    else
++		SvSETMAGIC(sv);
+ 	}
+     }
+ 
+diff --git a/t/op/sselect.t b/t/op/sselect.t
+index fedbfc7..9ec1c63 100644
+--- a/t/op/sselect.t
++++ b/t/op/sselect.t
+@@ -13,7 +13,7 @@ BEGIN {
+ skip_all("Win32 miniperl has no socket select")
+   if $^O eq "MSWin32" && is_miniperl();
+ 
+-plan (15);
++plan (16);
+ 
+ my $blank = "";
+ eval {select undef, $blank, $blank, 0};
+@@ -95,3 +95,12 @@ note("diff=$diff under=$under");
+     select (undef, undef, undef, $sleep);
+     ::is($count, 1, 'RT120102');
+ }
++
++package _131645{
++    sub TIESCALAR { bless [] }
++    sub FETCH     { 0        }
++    sub STORE     {          }
++}
++tie $tie, _131645::;
++select ($tie, undef, undef, $tie);
++ok("no crash from select $numeric_tie, undef, undef, $numeric_tie")
+-- 
+2.9.4
+

perl.spec

@@ -197,6 +197,10 @@ Patch48:        perl-5.27.1-add-an-additional-test-for-whitespace-tolerance-in-c
 # in upstream after 5.27.1
 Patch49:        perl-5.27.1-utf8n_to_uvchr-Don-t-display-too-many-bytes-in-msg.patch
 
+# Fix select called with a repeated magical variable, RT#131645,
+# in upstream after 5.27.1
+Patch50:        perl-5.27.1-perl-131645-Fix-assert-fail-in-pp_sselect.patch
+
 # Link XS modules to libperl.so with EU::CBuilder on Linux, bug #960048
 Patch200:       perl-5.16.3-Link-XS-modules-to-libperl.so-with-EU-CBuilder-on-Li.patch
 
@@ -2774,6 +2778,7 @@ Perl extension for Version Objects
 %patch47 -p1
 %patch48 -p1
 %patch49 -p1
+%patch50 -p1
 %patch200 -p1
 %patch201 -p1
 
@@ -2808,6 +2813,7 @@ perl -x patchlevel.h \
     'Fedora Patch46: Fix t/op/hash.t test random failures' \
     'Fedora Patch47: Parse caret variables with subscripts as normal variables inside ${...} escaping (RT#131664)' \
     'Fedora Patch49: Do not display too many bytes when reporting malformed UTF-8 character' \
+    'Fedora Patch50: Fix select called with a repeated magical variable (RT#131645)' \
     'Fedora Patch200: Link XS modules to libperl.so with EU::CBuilder on Linux' \
     'Fedora Patch201: Link XS modules to libperl.so with EU::MM on Linux' \
     %{nil}
@@ -5098,6 +5104,7 @@ popd
 - Parse caret variables with subscripts as normal variables inside ${...}
   escaping (RT#131664)
 - Do not display too many bytes when reporting malformed UTF-8 character
+- Fix select called with a repeated magical variable (RT#131645)
 
 * Sat Jul 29 2017 Igor Gnatenko <ignatenkobrain@fedoraproject.org> - 4:5.26.0-397
 - Enable separate debuginfo back