This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[rt.cpan.org #61577] try harder to get socket information
authorTony Cook <tony@develop-help.com>
Mon, 2 Jul 2012 09:41:19 +0000 (19:41 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 2 Jul 2012 09:41:19 +0000 (19:41 +1000)
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.

MANIFEST
META.yml
dist/IO/Makefile.PL
dist/IO/lib/IO/Socket.pm
dist/IO/t/cachepropagate-tcp.t [new file with mode: 0644]
dist/IO/t/cachepropagate-udp.t [new file with mode: 0644]
dist/IO/t/cachepropagate-unix.t [new file with mode: 0644]

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
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
index 2159f43..70ffe12 100644 (file)
@@ -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
     ? ()
     : (
index 529423b..8873fbf 100644 (file)
@@ -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
new file mode 100644 (file)
index 0000000..b9104bb
--- /dev/null
@@ -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 (file)
index 0000000..91cff37
--- /dev/null
@@ -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 (file)
index 0000000..c336a73
--- /dev/null
@@ -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);