develooper Front page | perl.perl5.porters | Postings from December 2001

socketpair emulation

Thread Next
From:
Nicholas Clark
Date:
December 22, 2001 12:01
Subject:
socketpair emulation
Message ID:
20011222183817.A12020@Bagpuss.unfortu.net
I believe that this is portable.  Test passes (or skips) correctly on real
socketpair, emulated socketpair and no socketpair.

Nicholas Clark

--- pod/perlfunc.pod.orig	Fri Dec 21 02:20:06 2001
+++ pod/perlfunc.pod	Sat Dec 22 18:17:44 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
 
--- /dev/null	Mon Jul 16 22:57:44 2001
+++ ext/Socket/socketpair.t	Sat Dec 22 18:13:49 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");
--- embed.pl.orig	Fri Dec 21 02:00:02 2001
+++ embed.pl	Sat Dec 22 16:25:37 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
 
--- perl.h.orig	Wed Dec 12 16:07:06 2001
+++ perl.h	Sat Dec 22 14:34:47 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
--- pp_sys.c.orig	Wed Dec 12 02:55:56 2001
+++ pp_sys.c	Sat Dec 22 14:39:55 2001
@@ -2280,7 +2280,7 @@
 
 PP(pp_sockpair)
 {
-#ifdef HAS_SOCKETPAIR
+#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET)
     dSP;
     GV *gv1;
     GV *gv2;
--- util.c.orig	Wed Dec 19 16:08:36 2001
+++ util.c	Sat Dec 22 16:25:16 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) */

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About