Bug#659075: perl-base: IO::Socket fails to propagate socket type information to accept()ed children

[Daniel Kahn Gillmor]

Subject: perl-base: IO::Socket fails to propagate socket type information to 
accept()ed children
Package: perl-base
Version: 5.14.2-6
Severity: normal
Tags: upstream patch
Forwarded: https://rt.cpan.org/Ticket/Display.html?id=61577

Running the attached test.pl shows the IO::Socket objects returned by
accept() don't retain the domain, protocol, or type information from the
listening socket, despite clearly sharing all of those features.

0 dkg@pip:~$ perl test.pl & sleep 1; nc localhost 2000; wait
[1] 31622
listener: domain: 2
listener: type: 1
accepting a connection...
new: undefined sockdomain
new: undefined socktype
[1]+  Done                    perl test.pl
0 dkg@pip:~$

The attached patch to IO/Socket.pm resolves the issue.

Note that this patch is intended to resolve CPAN's #61577 (as noted in
the Forwarded field), but that ticket itself is reputed to be the cause
of https://rt.cpan.org/Public/Bug/Display.html?id=68282, which is
reported to be the same as http://bugs.debian.org/607674 (reported by
intrigeri, cc'ed here).  I'm unable to replicate #607674 at the moment
myself, however, so i can't verify that this fix to IO::Socket would
result in fixing 607674.

Anyway, perhaps this patch could be considered for inclusion in debian?
Upstream would be better, of course, but upstream appears to be
remarkably unresponsive for what seems to me like a straightforward fix.

        --dkg

-- System Information:
Debian Release: wheezy/sid
  APT prefers testing
  APT policy: (500, 'testing'), (200, 'unstable'), (1, 'experimental')
Architecture: i386 (i686)

Kernel: Linux 3.2.0-1-686-pae (SMP w/1 CPU core)
Locale: LANG=en_US.UTF-8, LC_CTYPE=en_US.UTF-8 (charmap=UTF-8)
Shell: /bin/sh linked to /bin/dash

Versions of packages perl-base depends on:
ii  dpkg   1.16.1.2
ii  libc6  2.13-24

perl-base recommends no packages.

Versions of packages perl-base suggests:
ii  perl  5.14.2-6

-- no debconf information

#!/usr/bin/perl

use warnings;
use strict;

use IO::Socket;

use IO::Socket::INET;

sub printinfo {
  my $s = shift;
  my $label = shift;

  if (defined $s->sockdomain) {
    printf("%s: domain: %d\n", $label, $s->sockdomain);
  } else {
    printf("%s: undefined sockdomain\n", $label);
  }
  if (defined $s->socktype) {
    printf("%s: type: %d\n", $label, $s->socktype);
  } else {
    printf("%s: undefined socktype\n", $label);
  }
}

my $listener = IO::Socket::INET->new(Listen => 1,
                                     LocalAddr => 'localhost',
                                     LocalPort => 2000,
                                     ReuseAddr => 1,
                                     Proto => 'tcp');

printinfo($listener, 'listener');

print ("accepting a connection...\n");
my $new = $listener->accept();

printinfo($new, 'new');




--- /usr/lib/perl/5.14.2/IO/Socket.pm.orig	2012-02-07 21:12:42.000000000 -0500
+++ /usr/lib/perl/5.14.2/IO/Socket.pm	2012-02-07 21:13:57.000000000 -0500
@@ -236,6 +236,8 @@
     $peer = accept($new,$sock)
 	or return;
 
+    ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
+
     return wantarray ? ($new, $peer)
     	      	     : $new;
 }