summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--AUTHORS1
-rw-r--r--MANIFEST3
-rw-r--r--META.yml3
-rw-r--r--dist/IO/lib/IO/Socket.pm11
-rw-r--r--dist/IO/t/cachepropagate-tcp.t51
-rw-r--r--dist/IO/t/cachepropagate-udp.t34
-rw-r--r--dist/IO/t/cachepropagate-unix.t83
7 files changed, 185 insertions, 1 deletions
diff --git a/AUTHORS b/AUTHORS
index 88342aa283..1547be2d51 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 2be6ea76bb..1f5219de87 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 9271e61e8a..faa01d5af3 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/lib/IO/Socket.pm b/dist/IO/lib/IO/Socket.pm
index 529423b5fd..393f8368d1 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 0000000000..9c26b4502c
--- /dev/null
+++ b/dist/IO/t/cachepropagate-tcp.t
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use IO::Socket;
+use IO::Socket::INET;
+use Socket;
+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');
+
+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 0000000000..91cff376b2
--- /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 0000000000..375f28a574
--- /dev/null
+++ b/dist/IO/t/cachepropagate-unix.t
@@ -0,0 +1,83 @@
+#!/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 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');
+
+ 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');
+
+ $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);
+ }
View Lorry Controller Status