Stop system select from croaking on read-only COW ""

System select (select with 4 arguments) does not allow any of its
first three arguments to be read-only unless they are undef or
empty strings.

It does not work properly for read-only copy-on-write empty strings,
because it passes all copy-on-write through sv_force_normal under the
expectation that they will shortly be modified.  It should not be
doing that for read-only empty strings.

diff --git a/pp_sys.c b/pp_sys.c
index 2aa83a8..b837a1e 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1112,10 +1112,11 @@ PP(pp_sselect)
        SvGETMAGIC(sv);
        if (!SvOK(sv))
            continue;
-       if (SvIsCOW(sv))
-               sv_force_normal_flags(sv, 0);
-       if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
+       if (SvREADONLY(sv)) {
+           if (!(SvPOK(sv) && SvCUR(sv) == 0))
                Perl_croak_no_modify();
+       }
+       else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
        if (!SvPOK(sv)) {
            if (!SvPOKp(sv))
                Perl_ck_warner(aTHX_ packWARN(WARN_MISC),

diff --git a/t/op/sselect.t b/t/op/sselect.t
index ff8349e..83bd073 100644 (file)
--- a/t/op/sselect.t
+++ b/t/op/sselect.t
@@ -9,7 +9,7 @@ BEGIN {
 
 require 'test.pl';
 
-plan (11);
+plan (14);
 
 my $blank = "";
 eval {select undef, $blank, $blank, 0};
@@ -26,6 +26,16 @@ is ($@, "", 'select $blank ""     $blank 0');
 eval {select $blank, $blank, "", 0};
 is ($@, "", 'select $blank $blank ""     0');
 
+# Test with read-only copy-on-write empty string
+my($rocow) = keys%{{""=>undef}};
+Internals::SvREADONLY($rocow,1);
+eval {select $rocow, $blank, $blank, 0};
+is ($@, "", 'select $rocow     $blank $blank 0');
+eval {select $blank, $rocow, $blank, 0};
+is ($@, "", 'select $blank $rocow     $blank 0');
+eval {select $blank, $blank, $rocow, 0};
+is ($@, "", 'select $blank $blank $rocow     0');
+
 eval {select "a", $blank, $blank, 0};
 like ($@, qr/^Modification of a read-only value attempted/,
            'select "a"    $blank $blank 0');