In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/180423598522425cee5c55023c3bd133caa9b976?hp=49f4c4e423fa15e3da8c813a7526bb78740f9018>
- Log ----------------------------------------------------------------- commit 180423598522425cee5c55023c3bd133caa9b976 Merge: 49f4c4e f4ea075 Author: Tony Cook <[email protected]> Date: Mon Jul 2 19:41:19 2012 +1000 [rt.cpan.org #61577] try harder to get socket information also [perl #112736][debian #659075] One of the tests may fail on HP-UX (but doesn't on the machine I have access to) I plan to monitor smokes and add skips as needed. commit f4ea07588f035ef62b1d70eae8894bfaa3b8f9a0 Author: Dominic Hargreaves <[email protected]> Date: Wed May 9 19:09:18 2012 +0100 add Test::More as a prereq to Makefile.PL M dist/IO/Makefile.PL commit 40bf447173f7b8e9ca7be4996fea63edad03ba00 Author: Tony Cook <[email protected]> Date: Fri Jun 22 20:57:09 2012 +1000 bump IO::Socket version M dist/IO/lib/IO/Socket.pm commit 99e17eca674d27fda4436f61bab067328689ed8c Author: Tony Cook <[email protected]> Date: Fri Jun 22 20:25:06 2012 +1000 document the limitations of protocol(), sockdomain(), socktype() Determining these for a new_from_fd() socket has the following problems: protocol() depends on SO_PROTOCOL, and socktype() on SO_TYPE, not implemented on all systems. sockdomain() depends on sockname(), which is documented as unimplemented for AF_UNIX sockets on HP-UX. I'm not sure that detail is useful in the documentation. M dist/IO/lib/IO/Socket.pm commit dafec47dd840b2ba2153af4b21e710f71b9ba467 Author: Tony Cook <[email protected]> Date: Wed Jun 13 21:21:49 2012 +1000 [rt.cpan.org #61577] try to populate socket info when not cached The fixes are originally by Daniel Kahn Gillmor <[email protected]>, but I've made other changes. M dist/IO/lib/IO/Socket.pm M dist/IO/t/cachepropagate-udp.t M dist/IO/t/cachepropagate-unix.t commit 76d04ca39f974c1aee23c29a9dda0a643740c988 Author: Tony Cook <[email protected]> Date: Wed Jun 13 19:32:33 2012 +1000 [rt.cpan.org #61577] propagate socket details on accept M dist/IO/lib/IO/Socket.pm M dist/IO/t/cachepropagate-tcp.t M dist/IO/t/cachepropagate-unix.t commit 93a5d7bfc07a41ef26fb3e3b298a7d88c3741ed1 Author: Tony Cook <[email protected]> Date: Wed Jun 13 19:27:22 2012 +1000 [rt.cpan.org #61577] sockdomain and socktype undef on newly accepted sockets There appears to be a flaw in IO::Socket where some IO::Socket objects are unable to properly report their socktype, sockdomain, or protocol (they return undef, even when the underlying socket is sufficiently initialized to have these properties). The attached patch should cover IO::Socket objects created via accept(), new_from_fd(), new(), and anywhere else whose details haven't been properly cached. No new code should be executed on IO::Socket objects whose details are already cached and present. These tests were original written by Daniel Kahn Gillmor <[email protected]>, I've mangled them for use in a hopefully final fix for the issue. M MANIFEST M META.yml A dist/IO/t/cachepropagate-tcp.t A dist/IO/t/cachepropagate-udp.t A dist/IO/t/cachepropagate-unix.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 + META.yml | 3 + dist/IO/Makefile.PL | 3 + dist/IO/lib/IO/Socket.pm | 19 ++++++++- dist/IO/t/cachepropagate-tcp.t | 57 +++++++++++++++++++++++++ dist/IO/t/cachepropagate-udp.t | 34 +++++++++++++++ dist/IO/t/cachepropagate-unix.t | 88 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 206 insertions(+), 1 deletions(-) create mode 100644 dist/IO/t/cachepropagate-tcp.t create mode 100644 dist/IO/t/cachepropagate-udp.t create mode 100644 dist/IO/t/cachepropagate-unix.t diff --git a/MANIFEST b/MANIFEST index 079f5bb..e011dfa 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3238,6 +3238,9 @@ dist/IO/Makefile.PL IO extension makefile writer dist/IO/poll.c IO poll() emulation using select() dist/IO/poll.h IO poll() emulation using select() 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/io_const.t See if constants from IO work dist/IO/t/io_dir.t See if directory-related methods from IO work dist/IO/t/io_dup.t See if dup()-related methods from IO work diff --git a/META.yml b/META.yml index ecb660b..b3f0bff 100644 --- a/META.yml +++ b/META.yml @@ -78,6 +78,9 @@ no_index: - dist/IO/poll.c - dist/IO/poll.h - dist/IO/README + - dist/IO/t/cachepropagate-tcp.t + - dist/IO/t/cachepropagate-udp.t + - dist/IO/t/cachepropagate-unix.t - dist/IO/t/IO.t - dist/IO/t/io_const.t - dist/IO/t/io_dir.t diff --git a/dist/IO/Makefile.PL b/dist/IO/Makefile.PL index 2159f43..70ffe12 100644 --- a/dist/IO/Makefile.PL +++ b/dist/IO/Makefile.PL @@ -33,6 +33,9 @@ WriteMakefile( OBJECT => '$(O_FILES)', ABSTRACT => 'Perl core IO modules', AUTHOR => 'Graham Barr <[email protected]>', + PREREQ_PM => { + 'Test::More' => 0, + }, ( $PERL_CORE ? () : ( diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm index 529423b..8873fbf 100644 --- a/dist/IO/lib/IO/Socket.pm +++ b/dist/IO/lib/IO/Socket.pm @@ -24,7 +24,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); @ISA = qw(IO::Handle); -$VERSION = "1.34"; +$VERSION = "1.35"; @EXPORT_OK = qw(sockatmark); @@ -249,6 +249,8 @@ sub accept { $peer = accept($new,$sock) or return; + ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto ); + return wantarray ? ($new, $peer) : $new; } @@ -349,18 +351,27 @@ sub timeout { sub sockdomain { @_ == 1 or croak 'usage: $sock->sockdomain()'; my $sock = shift; + if (!defined(${*$sock}{'io_socket_domain'})) { + my $addr = $sock->sockname(); + ${*$sock}{'io_socket_domain'} = sockaddr_family($addr) + if (defined($addr)); + } ${*$sock}{'io_socket_domain'}; } sub socktype { @_ == 1 or croak 'usage: $sock->socktype()'; my $sock = shift; + ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE) + if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE})); ${*$sock}{'io_socket_type'} } sub protocol { @_ == 1 or croak 'usage: $sock->protocol()'; my($sock) = @_; + ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL) + if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL})); ${*$sock}{'io_socket_proto'}; } @@ -529,6 +540,12 @@ value returned. =back +=head1 LIMITATIONS + +On some systems, for an IO::Socket object created with new_from_fd(), +or created with accept() from such an object, the protocol(), +sockdomain() and socktype() methods may return undef. + =head1 SEE ALSO L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> diff --git a/dist/IO/t/cachepropagate-tcp.t b/dist/IO/t/cachepropagate-tcp.t new file mode 100644 index 0000000..b9104bb --- /dev/null +++ b/dist/IO/t/cachepropagate-tcp.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; +use IO::Socket::INET; +use Socket; +use Test::More; +use Config; + +plan tests => 8; + +my $listener = IO::Socket::INET->new(Listen => 1, + LocalAddr => '127.0.0.1', + Proto => 'tcp'); +ok(defined($listener), 'socket created'); + +my $port = $listener->sockport(); + +my $p = $listener->protocol(); +ok(defined($p), 'protocol defined'); +my $d = $listener->sockdomain(); +ok(defined($d), 'domain defined'); +my $s = $listener->socktype(); +ok(defined($s), 'type defined'); + +SKIP: { + skip "fork not available", 4 + unless $Config{d_fork} || $Config{d_pseudofork}; + + my $cpid = fork(); + if (0 == $cpid) { + # the child: + sleep(1); + my $connector = IO::Socket::INET->new(PeerAddr => '127.0.0.1', + PeerPort => $port, + Proto => 'tcp'); + exit(0); + } else {; + ok(defined($cpid), 'spawned a child'); + } + + my $new = $listener->accept(); + + is($new->sockdomain(), $d, 'domain match'); + SKIP: { + skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL }); + is($new->protocol(), $p, 'protocol match'); + } + SKIP: { + skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE }); + is($new->socktype(), $s, 'type match'); + } + + wait(); +} diff --git a/dist/IO/t/cachepropagate-udp.t b/dist/IO/t/cachepropagate-udp.t new file mode 100644 index 0000000..91cff37 --- /dev/null +++ b/dist/IO/t/cachepropagate-udp.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; +use IO::Socket::INET; +use Socket; +use Test::More; + +plan tests => 7; + +my $listener = IO::Socket::INET->new(LocalAddr => '127.0.0.1', + Proto => 'udp'); +ok(defined($listener), 'socket created'); + +my $p = $listener->protocol(); +ok(defined($p), 'protocol defined'); +my $d = $listener->sockdomain(); +ok(defined($d), 'domain defined'); +my $s = $listener->socktype(); +ok(defined($s), 'type defined'); + +my $new = IO::Socket::INET->new_from_fd($listener->fileno(), 'r+'); + +is($new->sockdomain(), $d, 'domain match'); +SKIP: { + skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL }); + is($new->protocol(), $p, 'protocol match'); +} +SKIP: { + skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE }); + is($new->socktype(), $s, 'type match'); +} diff --git a/dist/IO/t/cachepropagate-unix.t b/dist/IO/t/cachepropagate-unix.t new file mode 100644 index 0000000..c336a73 --- /dev/null +++ b/dist/IO/t/cachepropagate-unix.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use File::Temp qw(tempdir); +use File::Spec::Functions; +use IO::Socket; +use IO::Socket::UNIX; +use Socket; +use Config; +use Test::More; + +plan skip_all => "UNIX domain sockets not implemented on $^O" + if ($^O =~ m/^(?:qnx|nto|vos|MSWin32)$/); + +plan tests => 15; + +my $socketpath = catfile(tempdir( CLEANUP => 1 ), 'testsock'); + +# start testing stream sockets: +my $listener = IO::Socket::UNIX->new(Type => SOCK_STREAM, + Listen => 1, + Local => $socketpath); +ok(defined($listener), 'stream socket created'); + +my $p = $listener->protocol(); +ok(defined($p), 'protocol defined'); +my $d = $listener->sockdomain(); +ok(defined($d), 'domain defined'); +my $s = $listener->socktype(); +ok(defined($s), 'type defined'); + +SKIP: { + skip "fork not available", 4 + unless $Config{d_fork} || $Config{d_pseudofork}; + + my $cpid = fork(); + if (0 == $cpid) { + # the child: + sleep(1); + my $connector = IO::Socket::UNIX->new(Peer => $socketpath); + exit(0); + } else { + ok(defined($cpid), 'spawned a child'); + } + + my $new = $listener->accept(); + + is($new->sockdomain(), $d, 'domain match'); + SKIP: { + skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL }); + is($new->protocol(), $p, 'protocol match'); + } + SKIP: { + skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE }); + is($new->socktype(), $s, 'type match'); + } + + unlink($socketpath); + wait(); +} + +undef $TODO; +# now test datagram sockets: +$listener = IO::Socket::UNIX->new(Type => SOCK_DGRAM, + Local => $socketpath); +ok(defined($listener), 'datagram socket created'); + +$p = $listener->protocol(); +ok(defined($p), 'protocol defined'); +$d = $listener->sockdomain(); +ok(defined($d), 'domain defined'); +$s = $listener->socktype(); +ok(defined($s), 'type defined'); + +my $new = IO::Socket::UNIX->new_from_fd($listener->fileno(), 'r+'); + +is($new->sockdomain(), $d, 'domain match'); +SKIP: { + skip "no Socket::SO_PROTOCOL", 1 if !defined(eval { Socket::SO_PROTOCOL }); + is($new->protocol(), $p, 'protocol match'); +} +SKIP: { + skip "no Socket::SO_TYPE", 1 if !defined(eval { Socket::SO_TYPE }); + is($new->socktype(), $s, 'type match'); +} +unlink($socketpath); -- Perl5 Master Repository
