[rt.cpan.org #61577] try harder to get socket information

also [perl #112736][debian #659075] One of the tests may fail on HP-UX (but doesn't on the machine I have access to) I plan to monitor smokes and add skips as needed.
Perl · Jul 2, 2012 · 1804235 · 1804235
2 parents 49f4c4e + f4ea075
commit 1804235
Show file tree

Hide file tree

Showing 7 changed files with 206 additions and 1 deletion.
diff --git 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
@@ -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
@@ -33,6 +33,9 @@ WriteMakefile(
   OBJECT       => '$(O_FILES)',
   ABSTRACT     => 'Perl core IO modules',
   AUTHOR       => 'Graham Barr <gbarr@cpan.org>',
+  PREREQ_PM    => {
+    'Test::More' => 0,
+  },
   ( $PERL_CORE
     ? ()
     : (

diff --git 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<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>

diff --git a/dist/IO/t/cachepropagate-tcp.t 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
@@ -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
@@ -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);