diff --git a/MANIFEST b/MANIFEST index 079f5bb98c10..e011dfaf2510 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 ecb660bd2d1f..b3f0bffe1d09 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 2159f43e49e0..70ffe12acf48 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 ', + PREREQ_PM => { + 'Test::More' => 0, + }, ( $PERL_CORE ? () : ( diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm index 529423b5fde0..8873fbfc9771 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, L, L, L diff --git a/dist/IO/t/cachepropagate-tcp.t b/dist/IO/t/cachepropagate-tcp.t new file mode 100644 index 000000000000..b9104bba0903 --- /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 000000000000..91cff376b281 --- /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 000000000000..c336a73c69c1 --- /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);