From: Nicholas Clark Date: Sat, 22 Dec 2001 18:38:18 +0000 (+0000) Subject: socketpair emulation X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=02fc2eeebe0e138f51e361717ee5d2258b2c13d0;p=p5sagit%2Fp5-mst-13.2.git socketpair emulation Message-ID: <20011222183817.A12020@Bagpuss.unfortu.net> p4raw-id: //depot/perl@13858 --- diff --git a/MANIFEST b/MANIFEST index 8cfa207..6c21ada 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 fd65d07..c0cfa7f 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 adbfcc3..b881828 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 0000000..2f39bc0 --- /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 c19e004..71deea1 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 d25ffd7..4dfc8ef 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 1d65ca6..193b0fb 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -4421,7 +4421,9 @@ to C is essentially: shutdown(Rdr, 1); # no more writing for reader shutdown(Wtr, 0); # no more reading for writer -See L for an example of socketpair use. +See L 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 9fee8c9..771f913 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 b6ed287..bb20b20 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 4736f11..09af1de 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) */