Change 13858 by jhi@alpha on 2001/12/23 00:12:51
Subject: socketpair emulation
From: Nicholas Clark <[EMAIL PROTECTED]>
Date: Sat, 22 Dec 2001 18:38:18 +0000
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/MANIFEST#682 edit
.... //depot/perl/embed.h#317 edit
.... //depot/perl/embed.pl#307 edit
.... //depot/perl/ext/Socket/socketpair.t#1 add
.... //depot/perl/global.sym#193 edit
.... //depot/perl/perl.h#424 edit
.... //depot/perl/pod/perlfunc.pod#286 edit
.... //depot/perl/pp_sys.c#272 edit
.... //depot/perl/proto.h#360 edit
.... //depot/perl/util.c#306 edit
Differences ...
==== //depot/perl/MANIFEST#682 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Sat Dec 22 17:30:05 2001
+++ perl/MANIFEST Sat Dec 22 17:30:05 2001
@@ -535,6 +535,7 @@
ext/Socket/Socket.pm Socket extension Perl module
ext/Socket/Socket.t See if Socket works
ext/Socket/Socket.xs Socket extension external subroutines
+ext/Socket/socketpair.t See if socketpair works
ext/Storable/ChangeLog Storable extension
ext/Storable/Makefile.PL Storable extension
ext/Storable/MANIFEST Storable extension
==== //depot/perl/embed.h#317 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Sat Dec 22 17:30:05 2001
+++ perl/embed.h Sat Dec 22 17:30:05 2001
@@ -1203,6 +1203,9 @@
#define sv_pvn_force_flags Perl_sv_pvn_force_flags
#define sv_2pv_flags Perl_sv_2pv_flags
#define my_atof2 Perl_my_atof2
+#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET)
+#define my_socketpair Perl_my_socketpair
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -2717,6 +2720,9 @@
#define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c)
#define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c)
#define my_atof2(a,b) Perl_my_atof2(aTHX_ a,b)
+#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET)
+#define my_socketpair(a,b,c,d) Perl_my_socketpair(aTHX_ a,b,c,d)
+#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
==== //depot/perl/embed.pl#307 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl.~1~ Sat Dec 22 17:30:05 2001
+++ perl/embed.pl Sat Dec 22 17:30:05 2001
@@ -2353,6 +2353,9 @@
Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags
Apd |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags
Ap |char* |my_atof2 |const char *s|NV* value
+#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET)
+Ap |int |my_socketpair |int family|int type|int protocol|int fd[2]
+#endif
END_EXTERN_C
==== //depot/perl/global.sym#193 (text+w) ====
Index: perl/global.sym
--- perl/global.sym.~1~ Sat Dec 22 17:30:05 2001
+++ perl/global.sym Sat Dec 22 17:30:05 2001
@@ -604,3 +604,4 @@
Perl_sv_pvn_force_flags
Perl_sv_2pv_flags
Perl_my_atof2
+Perl_my_socketpair
==== //depot/perl/perl.h#424 (text) ====
Index: perl/perl.h
--- perl/perl.h.~1~ Sat Dec 22 17:30:05 2001
+++ perl/perl.h Sat Dec 22 17:30:05 2001
@@ -755,6 +755,12 @@
# endif
#endif
+#ifndef HAS_SOCKETPAIR
+# ifdef HAS_SOCKET
+# define socketpair Perl_my_socketpair
+# endif
+#endif
+
#if INTSIZE == 2
# define htoni htons
# define ntohi ntohs
==== //depot/perl/pod/perlfunc.pod#286 (text) ====
Index: perl/pod/perlfunc.pod
--- perl/pod/perlfunc.pod.~1~ Sat Dec 22 17:30:05 2001
+++ perl/pod/perlfunc.pod Sat Dec 22 17:30:05 2001
@@ -4421,7 +4421,9 @@
shutdown(Rdr, 1); # no more writing for reader
shutdown(Wtr, 0); # no more reading for writer
-See L<perlipc> for an example of socketpair use.
+See L<perlipc> for an example of socketpair use. Perl 5.8 and later will
+emulate socketpair using IP sockets to localhost if your system implements
+sockets but not socketpair.
=item sort SUBNAME LIST
==== //depot/perl/pp_sys.c#272 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c.~1~ Sat Dec 22 17:30:05 2001
+++ perl/pp_sys.c Sat Dec 22 17:30:05 2001
@@ -2280,7 +2280,7 @@
PP(pp_sockpair)
{
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET)
dSP;
GV *gv1;
GV *gv2;
==== //depot/perl/proto.h#360 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Sat Dec 22 17:30:05 2001
+++ perl/proto.h Sat Dec 22 17:30:05 2001
@@ -1331,6 +1331,9 @@
PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags);
PERL_CALLCONV char* Perl_my_atof2(pTHX_ const char *s, NV* value);
+#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET)
+PERL_CALLCONV int Perl_my_socketpair(pTHX_ int family, int type, int protocol,
+int fd[2]);
+#endif
END_EXTERN_C
==== //depot/perl/util.c#306 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Sat Dec 22 17:30:05 2001
+++ perl/util.c Sat Dec 22 17:30:05 2001
@@ -3967,4 +3967,225 @@
return s;
}
+#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET)
+static int
+S_socketpair_udp (int fd[2]) {
+ /* Fake a datagram socketpair using UDP to localhost. */
+ int sockets[2] = {-1, -1};
+ struct sockaddr_in addresses[2];
+ int i;
+ Sock_size_t size = sizeof (struct sockaddr_in);
+ short port;
+ int got;
+
+ memset (&addresses, 0, sizeof (addresses));
+ i = 1;
+ do {
+ sockets[i] = socket (AF_INET, SOCK_DGRAM, 0);
+ if (sockets[i] == -1)
+ goto tidy_up_and_fail;
+
+ addresses[i].sin_family = AF_INET;
+ addresses[i].sin_addr.s_addr = htonl (INADDR_LOOPBACK);
+ addresses[i].sin_port = 0; /* kernel choses port. */
+ if (bind (sockets[i], (struct sockaddr *) &addresses[i],
+ sizeof (struct sockaddr_in))
+ == -1)
+ goto tidy_up_and_fail;
+ } while (i--);
+
+ /* Now have 2 UDP sockets. Find out which port each is connected to, and
+ for each connect the other socket to it. */
+ i = 1;
+ do {
+ if (getsockname (sockets[i], (struct sockaddr *) &addresses[i], &size)
+ == -1)
+ goto tidy_up_and_fail;
+ if (size != sizeof (struct sockaddr_in))
+ goto abort_tidy_up_and_fail;
+ /* !1 is 0, !0 is 1 */
+ if (connect(sockets[!i], (struct sockaddr *) &addresses[i],
+ sizeof (struct sockaddr_in)) == -1)
+ goto tidy_up_and_fail;
+ } while (i--);
+ /* Now we have 2 sockets connected to each other. I don't trust some other
+ process not to have already sent a packet to us (by random) so send
+ a packet from each to the other. */
+ i = 1;
+ do {
+ /* I'm going to send my own port number. As a short.
+ (Who knows if someone somewhere has sin_port as a bitfield and needs
+ this routine. (I'm assuming crays have socketpair)) */
+ port = addresses[i].sin_port;
+ got = write (sockets[i], &port, sizeof(port));
+ if (got != sizeof(port)) {
+ if (got == -1)
+ goto tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
+ }
+ } while (i--);
+
+ /* Packets sent. I don't trust them to have arrived though.
+ (As I understand it Solaris TCP stack is multithreaded. Non-blocking
+ connect to localhost will use a second kernel thread. In 2.6 the
+ first thread running the connect() returns before the second completes,
+ so EINPROGRESS> In 2.7 the improved stack is faster and connect()
+ returns 0. Poor programs have tripped up. One poor program's authors'
+ had a 50-1 reverse stock split. Not sure how connected these were.)
+ So I don't trust someone not to have an unpredictable UDP stack.
+ */
+
+ {
+ struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
+ int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
+ fd_set rset;
+
+ FD_ZERO (&rset);
+ FD_SET (sockets[0], &rset);
+ FD_SET (sockets[1], &rset);
+
+ got = select (max + 1, &rset, NULL, NULL, &waitfor);
+ if (got != 2 || !FD_ISSET (sockets[0], &rset)
+ || !FD_ISSET (sockets[1], &rset)) {
+ /* I hope this is portable and appropriate. */
+ if (got == -1)
+ goto tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
+ }
+ }
+
+ /* And the paranoia department even now doesn't trust it to have arrive
+ (hence MSG_DONTWAIT). Or that what arrives was sent by us. */
+ {
+ struct sockaddr_in readfrom;
+ short buffer[2];
+
+ i = 1;
+ do {
+ got = recvfrom (sockets[i], (char *) &buffer, sizeof(buffer),
+#ifdef MSG_DONTWAIT
+ MSG_DONTWAIT,
+#else
+ 0,
+#endif
+ (struct sockaddr *) &readfrom, &size);
+
+ if (got == -1)
+ goto tidy_up_and_fail;
+ if (got != sizeof(port)
+ || size != sizeof (struct sockaddr_in)
+ /* Check other socket sent us its port. */
+ || buffer[0] != addresses[!i].sin_port
+ /* Check kernel says we got the datagram from that socket. */
+ || readfrom.sin_family != addresses[!i].sin_family
+ || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
+ || readfrom.sin_port != addresses[!i].sin_port)
+ goto abort_tidy_up_and_fail;
+ } while (i--);
+ }
+ /* My caller (my_socketpair) has validated that this is non-NULL */
+ fd[0] = sockets[0];
+ fd[1] = sockets[1];
+ /* I hereby declare this connection open. May God bless all who cross
+ her. */
+ return 0;
+
+ abort_tidy_up_and_fail:
+ errno = ECONNABORTED;
+ tidy_up_and_fail:
+ {
+ int save_errno = errno;
+ if (sockets[0] != -1)
+ close (sockets[0]);
+ if (sockets[1] != -1)
+ close (sockets[1]);
+ errno = save_errno;
+ return -1;
+ }
+}
+
+int
+Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
+ /* Stevens says that family must be AF_LOCAL, protocol 0.
+ I'm going to enforce that, then ignore it, and use TCP. */
+ int listener = -1;
+ int connector = -1;
+ int acceptor = -1;
+ struct sockaddr_in listen_addr;
+ struct sockaddr_in connect_addr;
+ Sock_size_t size;
+
+ if (protocol || family != AF_UNIX) {
+ errno = EAFNOSUPPORT;
+ return -1;
+ }
+ if (!fd)
+ return EINVAL;
+
+ if (type == SOCK_DGRAM)
+ return S_socketpair_udp (fd);
+
+ listener = socket (AF_INET, type, 0);
+ if (listener == -1)
+ return -1;
+ memset (&listen_addr, 0, sizeof (listen_addr));
+ listen_addr.sin_family = AF_INET;
+ listen_addr.sin_addr.s_addr = htonl (INADDR_LOOPBACK);
+ listen_addr.sin_port = 0; /* kernel choses port. */
+ if (bind (listener, (struct sockaddr *) &listen_addr, sizeof (listen_addr))
+ == -1)
+ goto tidy_up_and_fail;
+ if (listen(listener, 1) == -1)
+ goto tidy_up_and_fail;
+
+ connector = socket (AF_INET, type, 0);
+ if (connector == -1)
+ goto tidy_up_and_fail;
+ /* We want to find out the port number to connect to. */
+ size = sizeof (connect_addr);
+ if (getsockname (listener, (struct sockaddr *) &connect_addr, &size) == -1)
+ goto tidy_up_and_fail;
+ if (size != sizeof (connect_addr))
+ goto abort_tidy_up_and_fail;
+ if (connect(connector, (struct sockaddr *) &connect_addr,
+ sizeof (connect_addr)) == -1)
+ goto tidy_up_and_fail;
+
+ size = sizeof (listen_addr);
+ acceptor = accept (listener, (struct sockaddr *) &listen_addr, &size);
+ if (acceptor == -1)
+ goto tidy_up_and_fail;
+ if (size != sizeof (listen_addr))
+ goto abort_tidy_up_and_fail;
+ close (listener);
+ /* Now check we are talking to ourself by matching port and host on the
+ two sockets. */
+ if (getsockname (connector, (struct sockaddr *) &connect_addr, &size) == -1)
+ goto tidy_up_and_fail;
+ if (size != sizeof (connect_addr)
+ || listen_addr.sin_family != connect_addr.sin_family
+ || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
+ || listen_addr.sin_port != connect_addr.sin_port) {
+ goto abort_tidy_up_and_fail;
+ }
+ fd[0] = connector;
+ fd[1] = acceptor;
+ return 0;
+
+ abort_tidy_up_and_fail:
+ errno = ECONNABORTED; /* I hope this is portable and appropriate. */
+ tidy_up_and_fail:
+ {
+ int save_errno = errno;
+ if (listener != -1)
+ close (listener);
+ if (connector != -1)
+ close (connector);
+ if (acceptor != -1)
+ close (acceptor);
+ errno = save_errno;
+ return -1;
+ }
+}
+#endif /* !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) */
==== //depot/perl/ext/Socket/socketpair.t#1 (text) ====
Index: perl/ext/Socket/socketpair.t
--- perl/ext/Socket/socketpair.t.~1~ Sat Dec 22 17:30:05 2001
+++ perl/ext/Socket/socketpair.t Sat Dec 22 17:30:05 2001
@@ -0,0 +1,144 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bSocket\b/ &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use Socket;
+use Test::More;
+use strict;
+use warnings;
+
+my $skip_reason;
+
+if( !$Config{d_alarm} ) {
+ plan skip_all => "alarm() not implemented on this platform";
+} else {
+ # This should fail but not die if there is real socketpair
+ eval {socketpair LEFT, RIGHT, -1, -1, -1};
+ if ($@ =~ /^Unsupported socket function "socketpair" called/) {
+ plan skip_all => 'No socketpair (real or emulated)';
+ } else {
+ eval {AF_UNIX};
+ if ($@ =~ /^Your vendor has not defined Socket macro AF_UNIX/) {
+ plan skip_all => 'No AF_UNIX';
+ } else {
+ plan tests => 42;
+ }
+ }
+}
+
+# Too many things in this test will hang forever if something is wrong, so
+# we need a self destruct timer.
+$SIG{ALRM} = sub {die "Something unexpectedly hung during testing"};
+alarm(60);
+
+ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC),
+ "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)")
+ or print "# \$\! = $!";
+
+my @left = ("hello ", "world\n");
+my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here.
+
+foreach (@left) {
+ # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left");
+ is (syswrite (LEFT, $_), length $_, "syswrite to left");
+}
+foreach (@right) {
+ # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right");
+ is (syswrite (RIGHT, $_), length $_, "syswrite to right");
+}
+
+# stream socket, so our writes will become joined:
+my ($buffer, $expect);
+$expect = join '', @right;
+is (read (LEFT, $buffer, length $expect), length $expect, "read on left");
+is ($buffer, $expect, "content what we expected?");
+$expect = join '', @left;
+is (read (RIGHT, $buffer, length $expect), length $expect, "read on right");
+is ($buffer, $expect, "content what we expected?");
+
+ok (shutdown(LEFT, 1), "shutdown left for writing");
+# This will hang forever if eof is buggy.
+ok (eof RIGHT, "right is at EOF");
+
+my @gripping = (chr 255, chr 127);
+foreach (@gripping) {
+ is (syswrite (RIGHT, $_), length $_, "syswrite to right");
+}
+
+ok (!eof LEFT, "left is not at EOF");
+
+$expect = join '', @gripping;
+is (read (LEFT, $buffer, length $expect), length $expect, "read on left");
+is ($buffer, $expect, "content what we expected?");
+
+ok (close LEFT, "close left");
+ok (close RIGHT, "close right");
+
+# And now datagrams
+# I suspect we also need a self destruct time-bomb for these, as I don't see any
+# guarantee that the stack won't drop a UDP packet, even if it is for localhost.
+
+ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC),
+ "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)")
+ or print "# \$\! = $!";
+
+foreach (@left) {
+ # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left");
+ is (syswrite (LEFT, $_), length $_, "syswrite to left");
+}
+foreach (@right) {
+ # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right");
+ is (syswrite (RIGHT, $_), length $_, "syswrite to right");
+}
+
+# stream socket, so our writes will become joined:
+my ($total);
+$total = join '', @right;
+foreach $expect (@right) {
+ is (sysread (LEFT, $buffer, length $total), length $expect, "read on left");
+ is ($buffer, $expect, "content what we expected?");
+}
+$total = join '', @left;
+foreach $expect (@left) {
+ is (sysread (RIGHT, $buffer, length $total), length $expect, "read on right");
+ is ($buffer, $expect, "content what we expected?");
+}
+
+ok (shutdown(LEFT, 1), "shutdown left for writing");
+# eof uses buffering. eof is indicated by a sysread of zero.
+# but for a datagram socket there's no way it can know nothing will ever be
+# sent
+{
+ my $alarmed = 0;
+ local $SIG{ALRM} = sub { $alarmed = 1; };
+ print "# Approximate forever as 3 seconds. Wait 'forever'...\n";
+ alarm 3;
+ is (sysread (RIGHT, $buffer, 1), undef,
+ "read on right should be interrupted");
+ is ($alarmed, 1, "alarm should have fired");
+}
+alarm 30;
+
+#ok (eof RIGHT, "right is at EOF");
+
+foreach (@gripping) {
+ is (syswrite (RIGHT, $_), length $_, "syswrite to right");
+}
+
+$total = join '', @gripping;
+foreach $expect (@gripping) {
+ is (sysread (LEFT, $buffer, length $total), length $expect, "read on left");
+ is ($buffer, $expect, "content what we expected?");
+}
+
+ok (close LEFT, "close left");
+ok (close RIGHT, "close right");
End of Patch.
