In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/01b71c89216c9f447494638a5d108e13c45c3863?hp=be109f01e91266a4cf170323c0a8f0d915bae205>
- Log ----------------------------------------------------------------- commit 01b71c89216c9f447494638a5d108e13c45c3863 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 b6903614db213f07401367249dc84c896eb099b7 Author: Tony Cook <[email protected]> Date: Wed May 9 19:04:28 2012 +0100 sometimes fork() isn't available This was amended from the original Tony prepared in a parallel branch M dist/IO/t/cachepropagate-tcp.t M dist/IO/t/cachepropagate-unix.t commit 271d04eee1933df0971f54f7bf9a5ca3575e7e6a Author: Daniel Kahn Gillmor <[email protected]> Date: Fri Feb 17 14:29:14 2012 -0800 [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. M AUTHORS M MANIFEST M META.yml M dist/IO/lib/IO/Socket.pm A dist/IO/t/cachepropagate-tcp.t A dist/IO/t/cachepropagate-udp.t A dist/IO/t/cachepropagate-unix.t ----------------------------------------------------------------------- Summary of changes: AUTHORS | 1 + MANIFEST | 3 + META.yml | 3 + dist/IO/Makefile.PL | 3 + dist/IO/lib/IO/Socket.pm | 11 ++++- dist/IO/t/cachepropagate-tcp.t | 56 +++++++++++++++++++++++++ dist/IO/t/cachepropagate-udp.t | 34 +++++++++++++++ dist/IO/t/cachepropagate-unix.t | 88 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 198 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/AUTHORS b/AUTHORS index 88342aa..1547be2 100644 --- a/AUTHORS +++ b/AUTHORS @@ -250,6 +250,7 @@ Daniel Chetlin <[email protected]> Daniel Dragan <[email protected]> Daniel Frederick Crisman <[email protected]> Daniel Grisinger <[email protected]> +Daniel Kahn Gillmor <[email protected]> Daniel Lieberman <[email protected]> Daniel Muiño <[email protected]> Daniel P. Berrange <[email protected]> diff --git a/MANIFEST b/MANIFEST index 2be6ea7..1f5219d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3259,6 +3259,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 9271e61..faa01d5 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..393f836 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); @@ -349,18 +349,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'}; } diff --git a/dist/IO/t/cachepropagate-tcp.t b/dist/IO/t/cachepropagate-tcp.t new file mode 100644 index 0000000..cec9a7b --- /dev/null +++ b/dist/IO/t/cachepropagate-tcp.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; +use IO::Socket::INET; +use Socket; +use Config; +use Test::More; + +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: { + $Config{d_pseudofork} || $Config{d_fork} + or skip("no fork", 4); + 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..1b0ace7 --- /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 tests => 15; + +SKIP: { + skip "UNIX domain sockets not implemented on $^O", 15 if ($^O =~ m/^(?:qnx|nto|vos|MSWin32)$/); + + 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: { + $Config{d_pseudofork} || $Config{d_fork} + or skip("no fork", 4); + 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(); + } + + # 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
