diff --git a/AUTHORS b/AUTHORS index 88342aa283e2..1547be2d51ad 100644 --- a/AUTHORS +++ b/AUTHORS @@ -250,6 +250,7 @@ Daniel Chetlin Daniel Dragan Daniel Frederick Crisman Daniel Grisinger +Daniel Kahn Gillmor Daniel Lieberman Daniel Muiño Daniel P. Berrange diff --git a/MANIFEST b/MANIFEST index 2be6ea76bb8a..1f5219de87e5 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 9271e61e8a43..faa01d5af397 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/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm index 529423b5fde0..393f8368d185 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 000000000000..9c26b4502c48 --- /dev/null +++ b/dist/IO/t/cachepropagate-tcp.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use IO::Socket; +use IO::Socket::INET; +use Socket; +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'); + +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..375f28a57497 --- /dev/null +++ b/dist/IO/t/cachepropagate-unix.t @@ -0,0 +1,83 @@ +#!/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 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'); + + 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'); + + $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); + }