socketpair emulation

Message-ID: <20011222183817.A12020@Bagpuss.unfortu.net>

p4raw-id: //depot/perl@13858

10 files changed, 389 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index 8cfa207e2b..6c21adaa1e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -535,6 +535,7 @@ ext/Socket/Makefile.PL		Socket extension makefile writer
 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
diff --git a/embed.h b/embed.h
index fd65d07c39..c0cfa7f789 100644
--- a/embed.h
+++ b/embed.h
@@ -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)
diff --git a/embed.pl b/embed.pl
index adbfcc38ed..b881828d11 100755
--- a/embed.pl
+++ b/embed.pl
@@ -2353,6 +2353,9 @@ Apd	|STRLEN	|sv_utf8_upgrade_flags|SV *sv|I32 flags
 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
 
diff --git a/ext/Socket/socketpair.t b/ext/Socket/socketpair.t
new file mode 100644
index 0000000000..2f39bc08a6
--- /dev/null
+++ b/ext/Socket/socketpair.t
@@ -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");
diff --git a/global.sym b/global.sym
index c19e004d66..71deea17f3 100644
--- a/global.sym
+++ b/global.sym
@@ -604,3 +604,4 @@ Perl_sv_utf8_upgrade_flags
 Perl_sv_pvn_force_flags
 Perl_sv_2pv_flags
 Perl_my_atof2
+Perl_my_socketpair
diff --git a/perl.h b/perl.h
index d25ffd7f22..4dfc8ef09f 100644
--- a/perl.h
+++ b/perl.h
@@ -755,6 +755,12 @@ int sockatmark(int);
 #   endif
 #endif
 
+#ifndef HAS_SOCKETPAIR
+#   ifdef HAS_SOCKET
+#	define socketpair Perl_my_socketpair
+#   endif
+#endif
+
 #if INTSIZE == 2
 #   define htoni htons
 #   define ntohi ntohs
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 1d65ca6fde..193b0fb2fd 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4421,7 +4421,9 @@ to C<pipe(Rdr, Wtr)> is essentially:
     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
 
diff --git a/pp_sys.c b/pp_sys.c
index 9fee8c90bd..771f9139d4 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2280,7 +2280,7 @@ PP(pp_socket)
 
 PP(pp_sockpair)
 {
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET)
     dSP;
     GV *gv1;
     GV *gv2;
diff --git a/proto.h b/proto.h
index b6ed2872aa..bb20b20a4c 100644
--- a/proto.h
+++ b/proto.h
@@ -1331,6 +1331,9 @@ PERL_CALLCONV STRLEN	Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags);
 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
 
diff --git a/util.c b/util.c
index 4736f11fdf..09af1de710 100644
--- a/util.c
+++ b/util.c
@@ -3967,4 +3967,225 @@ Perl_new_vstring(pTHX_ char *s, SV *sv)
     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) */