[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
<dkg@fifthhorseman.net>, I've mangled them for use in a hopefully
final fix for the issue.

diff --git a/MANIFEST b/MANIFEST
index 079f5bb..e011dfa 100644 (file)
--- 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 (file)
--- 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/t/cachepropagate-tcp.t b/dist/IO/t/cachepropagate-tcp.t
new file mode 100644 (file)
index 0000000..6bc2efe
--- /dev/null
+++ b/dist/IO/t/cachepropagate-tcp.t
@@ -0,0 +1,58 @@
+#!/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();
+
+    local $TODO = "this information isn't cached for accepted sockets";
+    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 (file)
index 0000000..de18eae
--- /dev/null
+++ b/dist/IO/t/cachepropagate-udp.t
@@ -0,0 +1,35 @@
+#!/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+');
+
+local $TODO = "this information isn't cached for accepted sockets";
+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 (file)
index 0000000..3e3a73a
--- /dev/null
+++ b/dist/IO/t/cachepropagate-unix.t
@@ -0,0 +1,90 @@
+#!/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();
+
+    $TODO = "this information isn't cached for accepted sockets";
+    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+');
+
+$TODO = "this information isn't cached for new_from_fd sockets";
+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);