summaryrefslogtreecommitdiff
path: root/dist
diff options
context:
space:
mode:
authorDaniel Kahn Gillmor <dkg@fifthhorseman.net>2012-02-17 14:29:14 -0800
committerRicardo Signes <rjbs@cpan.org>2012-05-10 09:53:14 -0400
commit271d04eee1933df0971f54f7bf9a5ca3575e7e6a (patch)
tree75270f1a3be0ff4d47e8ec9aa6fbaa8fae48a54d /dist
parentbe109f01e91266a4cf170323c0a8f0d915bae205 (diff)
downloadperl-271d04eee1933df0971f54f7bf9a5ca3575e7e6a.tar.gz
[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.
Diffstat (limited to 'dist')
-rw-r--r--dist/IO/lib/IO/Socket.pm11
-rw-r--r--dist/IO/t/cachepropagate-tcp.t51
-rw-r--r--dist/IO/t/cachepropagate-udp.t34
-rw-r--r--dist/IO/t/cachepropagate-unix.t83
4 files changed, 178 insertions, 1 deletions
diff --git a/dist/IO/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
index 529423b5fd..393f8368d1 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 0000000000..9c26b4502c
--- /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 0000000000..91cff376b2
--- /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 0000000000..375f28a574
--- /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);
+ }