[perl.git] branch blead, updated. v5.15.9-285-g01b71c8

In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/01b71c89216c9f447494638a5d108e13c45c3863?hp=be109f01e91266a4cf170323c0a8f0d915bae205>

- Log -----------------------------------------------------------------
commit 01b71c89216c9f447494638a5d108e13c45c3863
Author: Dominic Hargreaves <dom@earth.li>
Date:   Wed May 9 19:09:18 2012 +0100

    add Test::More as a prereq to Makefile.PL

M	dist/IO/Makefile.PL

commit b6903614db213f07401367249dc84c896eb099b7
Author: Tony Cook <tony@develop-help.com>
Date:   Wed May 9 19:04:28 2012 +0100

    sometimes fork() isn't available
    
    This was amended from the original Tony prepared in a parallel branch

M	dist/IO/t/cachepropagate-tcp.t
M	dist/IO/t/cachepropagate-unix.t

commit 271d04eee1933df0971f54f7bf9a5ca3575e7e6a
Author: Daniel Kahn Gillmor <dkg@fifthhorseman.net>
Date:   Fri Feb 17 14:29:14 2012 -0800

    [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.

M	AUTHORS
M	MANIFEST
M	META.yml
M	dist/IO/lib/IO/Socket.pm
A	dist/IO/t/cachepropagate-tcp.t
A	dist/IO/t/cachepropagate-udp.t
A	dist/IO/t/cachepropagate-unix.t
-----------------------------------------------------------------------

Summary of changes:
 AUTHORS                         |    1 +
 MANIFEST                        |    3 +
 META.yml                        |    3 +
 dist/IO/Makefile.PL             |    3 +
 dist/IO/lib/IO/Socket.pm        |   11 ++++-
 dist/IO/t/cachepropagate-tcp.t  |   56 +++++++++++++++++++++++++
 dist/IO/t/cachepropagate-udp.t  |   34 +++++++++++++++
 dist/IO/t/cachepropagate-unix.t |   88 +++++++++++++++++++++++++++++++++++++++
 8 files changed, 198 insertions(+), 1 deletions(-)
 create mode 100644 dist/IO/t/cachepropagate-tcp.t
 create mode 100644 dist/IO/t/cachepropagate-udp.t
 create mode 100644 dist/IO/t/cachepropagate-unix.t

diff --git a/AUTHORS b/AUTHORS
index 88342aa..1547be2 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -250,6 +250,7 @@ Daniel Chetlin			<daniel@chetlin.com>
 Daniel Dragan			<bulk88@hotmail.com>
 Daniel Frederick Crisman	<daniel@crisman.org>
 Daniel Grisinger		<dgris@dimensional.com>
+Daniel Kahn Gillmor		<dkg@fifthhorseman.net>
 Daniel Lieberman		<daniel@bitpusher.com>
 Daniel Muiño			<dmuino@afip.gov.ar>
 Daniel P. Berrange		<dan@berrange.com>
diff --git a/MANIFEST b/MANIFEST
index 2be6ea7..1f5219d 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 9271e61..faa01d5 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/Makefile.PL b/dist/IO/Makefile.PL
index 2159f43..70ffe12 100644
--- 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
index 529423b..393f836 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 0000000..cec9a7b
--- /dev/null
+++ b/dist/IO/t/cachepropagate-tcp.t
@@ -0,0 +1,56 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use IO::Socket;
+use IO::Socket::INET;
+use Socket;
+use Config;
+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');
+
+SKIP: {
+  $Config{d_pseudofork} || $Config{d_fork}
+    or skip("no fork", 4);
+  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 0000000..91cff37
--- /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 0000000..1b0ace7
--- /dev/null
+++ 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 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');
+
+  SKIP: {
+    $Config{d_pseudofork} || $Config{d_fork}
+      or skip("no fork", 4);
+    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');
+
+  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);
+}

--
Perl5 Master Repository

• [perl.git] branch blead, updated. v5.15.9-285-g01b71c8 by Ricardo Signes