Skip Menu |

This queue is for tickets about the IO CPAN distribution.

Report information
The Basics
Id: 93107
Status: resolved
Priority: 0/
Queue: IO

People
Owner: Nobody in particular
Requestors: leonerd-cpan [...] leonerd.org.uk
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: (no value)



Subject: IO::Poll relies on stable stringification of IO handles
IO::Poll uses IO objects as keys in internal hashes, relying therefore on the stringification of these IO handles to be stable. The use of IO::Socket::SSL and late-upgrade after creation breaks this logic. For better or worse, IO::Socket::SSL->SSL_upgrade performs a rebless operation on the IO handle object, thus changing its stringification. This bug manifests itself when using SSL upgrades on IO::Poll-multiplexed sockets, causing a 100% CPU spin the first time a socket is closed. The different stringification of the object handle means that $poll->remove() doesn't successfully remove it, causing the underlying poll(2) call to the kernel to still request a now-invalid file descriptor, causing it to return instantly with POLLNVAL. I would suggest instead all uses of {$io} as a hash key be replaced with {refaddr $io}, because the refaddr of an object /is/ guaranteed inviolate during its lifetime. -- Paul Evans
On Mon Feb 17 20:51:18 2014, PEVANS wrote: Show quoted text
> I would suggest instead all uses of {$io} as a hash key be replaced > with {refaddr $io}, because the refaddr of an object /is/ guaranteed > inviolate during its lifetime.
As a side benefit, this would also defend against IO handles with stringification overload magic, which would otherwise either fail to identify, or would cause identity clashes if they overlapped. -- Paul Evans
On Mon Feb 17 20:51:18 2014, PEVANS wrote: Show quoted text
> I would suggest instead all uses of {$io} as a hash key be replaced > with {refaddr $io}, because the refaddr of an object /is/ guaranteed > inviolate during its lifetime.
Bugfix + regression test attached. -- Paul Evans
Subject: rt93107.patch
=== modified file 'lib/IO/Poll.pm' --- lib/IO/Poll.pm 2014-02-20 17:42:18 +0000 +++ lib/IO/Poll.pm 2014-02-20 18:01:49 +0000 @@ -10,6 +10,7 @@ use strict; use IO::Handle; use Exporter (); +use Scalar::Util qw( refaddr ); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); @@ -31,9 +32,9 @@ POLLNORM ); -# [0] maps fd's to requested masks +# [0] maps fd's to hashes that map handles to requested masks # [1] maps fd's to returned masks -# [2] maps fd's to handles +# [2] maps handle addrs to handles sub new { my $class = shift; @@ -50,22 +51,22 @@ if (@_) { my $mask = shift; if($mask) { - $self->[0]{$fd}{$io} = $mask; # the error events are always returned - $self->[1]{$fd} = 0; # output mask - $self->[2]{$io} = $io; # remember handle + $self->[0]{$fd}{refaddr $io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{refaddr $io} = $io; # remember handle } else { - delete $self->[0]{$fd}{$io}; + delete $self->[0]{$fd}{refaddr $io}; unless(%{$self->[0]{$fd}}) { # We no longer have any handles for this FD delete $self->[1]{$fd}; delete $self->[0]{$fd}; } - delete $self->[2]{$io}; + delete $self->[2]{refaddr $io}; } } - return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; - return $self->[0]{$fd}{$io}; + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{refaddr $io}; + return $self->[0]{$fd}{refaddr $io}; } @@ -100,8 +101,8 @@ my $self = shift; my $io = shift; my $fd = fileno($io); - exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) + exists $self->[1]{$fd} and exists $self->[0]{$fd}{refaddr $io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{refaddr $io}|POLLHUP|POLLERR|POLLNVAL) : 0; } === added file 't/rt93107.t' --- t/rt93107.t 1970-01-01 00:00:00 +0000 +++ t/rt93107.t 2014-02-20 18:01:49 +0000 @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +# Regression test for https://rt.cpan.org/Ticket/Display.html?id=93107 + +use strict; +use warnings; + +use Test::More; + +use IO::Poll; + +use IO::Handle; + +package NewIOHandle { + use base qw( IO::Handle ); +} + +pipe( my $rd, my $wr ) or die "Cannot pipe() - $!"; +$wr->syswrite( "data\n" ); +# $rd should now be readable + +my $poll = IO::Poll->new; +$poll->mask( $rd, POLLIN ); + +my $ret = $poll->poll( 0 ); +is( $ret, 1, 'poll() indicates 1 filehandle is ready' ); +is( $poll->events( $rd ), POLLIN, 'poll() indicates $rd has POLLIN' ); + +bless $rd, "NewIOHandle"; + +is( $poll->mask( $rd ), POLLIN, '$poll still has POLLIN mask for reblessed handle' ); +$ret = $poll->poll( 0 ); +is( $ret, 1, 'poll() indicates 1 filehandle is ready after rebless' ); +is( $poll->events( $rd ), POLLIN, 'poll() indicates reblessed $rd still has POLLIN' ); + +$poll->remove( $rd ); +$rd->close; + +$ret = $poll->poll( 0 ); +is( $ret, 0, 'poll() times out after remove' ); + +done_testing;
Ticket migrated to github as https://github.com/toddr/IO/issues/29