diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | META.json | 1 | ||||
| -rw-r--r-- | META.yml | 1 | ||||
| -rw-r--r-- | dist/IO/lib/IO/Select.pm | 18 | ||||
| -rw-r--r-- | dist/IO/t/gh17447.t | 29 |
5 files changed, 48 insertions, 2 deletions
@@ -3670,6 +3670,7 @@ dist/IO/README IO extension maintenance notice dist/IO/t/cachepropagate-tcp.t See if IO::Socket duplication works dist/IO/t/cachepropagate-udp.t See if IO::Socket duplication works dist/IO/t/cachepropagate-unix.t See if IO::Socket duplication works +dist/IO/t/gh17447.t Tests fix for #17447 dist/IO/t/IO.t See if IO works dist/IO/t/io_const.t See if constants from IO work dist/IO/t/io_dir.t See if directory-related methods from IO work @@ -81,6 +81,7 @@ "dist/IO/t/cachepropagate-tcp.t", "dist/IO/t/cachepropagate-udp.t", "dist/IO/t/cachepropagate-unix.t", + "dist/IO/t/gh17447.t", "dist/IO/t/IO.t", "dist/IO/t/io_const.t", "dist/IO/t/io_dir.t", @@ -78,6 +78,7 @@ no_index: - dist/IO/t/cachepropagate-tcp.t - dist/IO/t/cachepropagate-udp.t - dist/IO/t/cachepropagate-unix.t + - dist/IO/t/gh17447.t - dist/IO/t/IO.t - dist/IO/t/io_const.t - dist/IO/t/io_dir.t diff --git a/dist/IO/lib/IO/Select.pm b/dist/IO/lib/IO/Select.pm index 980a7e9c69..35a47ccbe0 100644 --- a/dist/IO/lib/IO/Select.pm +++ b/dist/IO/lib/IO/Select.pm @@ -10,7 +10,7 @@ use strict; use warnings::register; require Exporter; -our $VERSION = "1.41"; +our $VERSION = "1.42"; our @ISA = qw(Exporter); # This is only so we can do version checking @@ -57,7 +57,21 @@ sub _fileno my($self, $f) = @_; return unless defined $f; $f = $f->[0] if ref($f) eq 'ARRAY'; - ($f =~ /^\d+$/) ? $f : fileno($f); + if($f =~ /^[0-9]+$/) { # plain file number + return $f; + } + elsif(defined(my $fd = fileno($f))) { + return $fd; + } + else { + # Neither a plain file number nor an opened filehandle; but maybe it was + # previously registered and has since been closed. ->remove still wants to + # know what fileno it had + foreach my $i ( FIRST_FD .. $#$self ) { + return $i - FIRST_FD if $self->[$i] == $f; + } + return undef; + } } sub _update diff --git a/dist/IO/t/gh17447.t b/dist/IO/t/gh17447.t new file mode 100644 index 0000000000..bcdec4b0f9 --- /dev/null +++ b/dist/IO/t/gh17447.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# Regression test for https://github.com/Perl/perl5/issues/17447 + +use strict; +use warnings; + +use Test::More tests => 2; + +use IO::Select; +use IO::Handle; + +pipe( my $rd, my $wr ) or die "Cannot pipe() - $!"; +binmode $rd; +binmode $wr; +$wr->syswrite("data\n"); + +my $select = IO::Select->new(); +$select->add($rd); + +is( scalar $select->handles, 1, '$select has 1 handle' ); + +# close first, then remove afterwards +$rd->close; +$select->remove($rd); + +is( scalar $select->handles, 0, '$select has 0 handles' ); + +exit; |