summaryrefslogtreecommitdiff
path: root/dist
diff options
context:
space:
mode:
Diffstat (limited to 'dist')
-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
4 files changed, 178 insertions, 1 deletions
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