Passing read only values (such as string constants) to select should

croak.

p4raw-id: //depot/perl@24795

diff --git a/MANIFEST b/MANIFEST
index fd78a2a..953bfaf 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2895,6 +2895,7 @@ t/op/split.t                      See if split works
 t/op/sprintf2.t                        See if sprintf works
 t/op/sprintf.t                 See if sprintf works
 t/op/srand.t                   See if srand works
+t/op/sselect.t                 See if 4 argument select works
 t/op/stash.t                   See if %:: stashes work
 t/op/stat.t                    See if stat works
 t/op/study.t                   See if study works

diff --git a/pp_sys.c b/pp_sys.c
index ff80272..1444a0f 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1024,9 +1024,16 @@ PP(pp_sselect)
 
     SP -= 4;
     for (i = 1; i <= 3; i++) {
-       if (!SvPOK(SP[i]))
+       SV *sv = SP[i];
+       if (SvOK(sv) && SvREADONLY(sv)) {
+           if (SvIsCOW(sv))
+               sv_force_normal_flags(sv, 0);
+           if (SvREADONLY(sv))
+               DIE(aTHX_ PL_no_modify);
+       }
+       if (!SvPOK(sv))
            continue;
-       j = SvCUR(SP[i]);
+       j = SvCUR(sv);
        if (maxlen < j)
            maxlen = j;
     }

diff --git a/t/op/sselect.t b/t/op/sselect.t
new file mode 100644 (file)
index 0000000..4e50b29
--- /dev/null
+++ b/t/op/sselect.t
@@ -0,0 +1,25 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = ('.', '../lib');
+}
+
+require 'test.pl';
+
+plan (6);
+
+my $blank = "";
+eval {select undef, $blank, $blank, 0};
+is ($@, "");
+eval {select $blank, undef, $blank, 0};
+is ($@, "");
+eval {select $blank, $blank, undef, 0};
+is ($@, "");
+
+eval {select "", $blank, $blank, 0};
+like ($@, qr/^Modification of a read-only value attempted/);
+eval {select $blank, "", $blank, 0};
+like ($@, qr/^Modification of a read-only value attempted/);
+eval {select $blank, $blank, "", 0};
+like ($@, qr/^Modification of a read-only value attempted/);