Make 4-argument select() handle UTF8-flagged strings correctly.

Issue #19882

3 files changed, 90 insertions, 3 deletions

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index a2584f9592..c18767c742 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -412,6 +412,14 @@ setsockopt() now uses the mechanism added in 5.36 to better
 distinguish between numeric and string values supplied as the
 C<OPTVAL> parameter.  [github #18761]
 
+=item *
+
+4-argument C<select()> now rejects strings with code points above
+255. Additionally, for code points 128-255, this operator will now always
+give the corresponding octet to the OS, regardless of how Perl stores
+such code points in memory. (Previously Perl leaked its internal string
+storage to the OS.)
+
 =back
 
 =head1 Known Problems
diff --git a/pp_sys.c b/pp_sys.c
index 09f6b8f8f8..f1026923a6 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1165,7 +1165,10 @@ PP(pp_sselect)
                 Perl_croak_no_modify();
         }
         else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
-        if (!SvPOK(sv)) {
+        if (SvPOK(sv)) {
+            if (SvUTF8(sv)) sv_utf8_downgrade(sv, FALSE);
+        }
+        else {
             if (!SvPOKp(sv))
                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                                     "Non-string passed as bitmask");
diff --git a/t/op/sselect.t b/t/op/sselect.t
index 9ec1c63d7f..bf34b7d400 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 (16);
+plan (23);
 
 my $blank = "";
 eval {select undef, $blank, $blank, 0};
@@ -103,4 +103,80 @@ package _131645{
 }
 tie $tie, _131645::;
 select ($tie, undef, undef, $tie);
-ok("no crash from select $numeric_tie, undef, undef, $numeric_tie")
+ok("no crash from select $numeric_tie, undef, undef, $numeric_tie");
+
+SKIP: {
+    my $SKIP_CR = sub {
+        skip shift, 4;
+    };
+
+    if ($^O =~ m<win32|vms>i) {
+        $SKIP_CR->("Perl's 4-arg select() in $^O only works with sockets.");
+    }
+
+    eval { require POSIX } or do {
+        $SKIP_CR->("Failed to load POSIX.pm: $@");
+    };
+
+    my $mask;
+
+    for (my $f=0; $f<100; $f++) {
+        my $fd = POSIX::dup(fileno \*STDOUT);
+
+        if (!defined $fd) {
+            $SKIP_CR->("dup(STDOUT): $!");
+            last UTF8TEST;
+        }
+
+        vec( my $curmask, $fd, 1 ) = 1;
+
+        if ($curmask =~ tr<\x80-\xff><>) {
+            note("FD = $fd");
+            $mask = $curmask;
+            last;
+        }
+    }
+
+
+    if (defined $mask) {
+        utf8::downgrade($mask);
+        my $mask2;
+
+        my $result = select $mask2 = $mask, undef, undef, 0;
+
+        isnt( $result, -1, 'select() read on non-utf8-flagged mask' );
+
+        utf8::upgrade($mask);
+        $result = select $mask2 = $mask, undef, undef, 0;
+
+        isnt( $result, -1, 'select() read on utf8-flagged mask' );
+
+        # ----------------------------------------
+
+        utf8::downgrade($mask);
+        $result = select undef, $mask2 = $mask, undef, 0;
+
+        isnt( $result, -1, 'select() write on non-utf8-flagged mask' );
+
+        utf8::upgrade($mask);
+        $result = select undef, $mask2 = $mask, undef, 0;
+
+        isnt( $result, -1, 'select() write on utf8-flagged mask' );
+    }
+    else {
+        $SKIP_CR->("No suitable file descriptor for UTF-8-flag test found.");
+    }
+}
+
+{
+    my $badmask = "\x{100}";
+
+    eval { select $badmask, undef, undef, 0 };
+    ok( $@, 'select() read fails when given a wide character' );
+
+    eval { select undef, $badmask, undef, 0 };
+    ok( $@, 'select() write fails when given a wide character' );
+
+    eval { select undef, undef, $badmask, 0 };
+    ok( $@, 'select() exception fails when given a wide character' );
+}