[perl #118843] work around recv() behaviour on cygwin

cygwin inherits recv behaviour from the Win32 sockets API which doesn't
modify the namebuf or it's associated size when you recv() from a
connected socket, handle this the same way Win32 does by zeroing the
length if it's the same as before calling recv().

Also adds some basic socket function tests to the core tests.

diff --git a/MANIFEST b/MANIFEST
index ab62ee6..efa172d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4909,6 +4909,7 @@ t/io/read.t                       See if read works
 t/io/say.t                     See if say works
 t/io/sem.t                     See if SysV semaphores work
 t/io/shm.t                     See if SysV shared memory works
+t/io/socket.t                  See if socket functions work
 t/io/tell.t                    See if file seeking works
 t/io/through.t                 See if pipe passes data intact
 t/io/utf8.t                    See if file seeking works

diff --git a/pp_sys.c b/pp_sys.c
index 3cd542c..3ec7dbe 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1711,6 +1711,14 @@ PP(pp_sysread)
        if (!(IoFLAGS(io) & IOf_UNTAINT))
            SvTAINTED_on(bufsv);
        SP = ORIGMARK;
+#if defined(__CYGWIN__)
+        /* recvfrom() on cygwin doesn't set bufsize at all for
+           connected sockets, leaving us with trash in the returned
+           name, so use the same test as the Win32 code to check if it
+           wasn't set, and set it [perl #118843] */
+        if (bufsize == sizeof namebuf)
+            bufsize = 0;
+#endif
        sv_setpvn(TARG, namebuf, bufsize);
        PUSHs(TARG);
        RETURN;

diff --git a/t/io/socket.t b/t/io/socket.t
new file mode 100644 (file)
index 0000000..b723e3c
--- /dev/null
+++ b/t/io/socket.t
@@ -0,0 +1,141 @@
+#!perl
+
+# sanity tests for socket functions
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib' && -d '../ext';
+
+    require "./test.pl";
+    require Config; import Config;
+
+    skip_all_if_miniperl();
+    for my $needed (qw(d_socket d_getpbyname)) {
+       if ($Config{$needed} ne 'define') {
+           skip_all("-- \$Config{$needed} undefined");
+       }
+    }
+    unless ($Config{extensions} =~ /\bSocket\b/) {
+       skip_all('-- Socket not available');
+    }
+}
+
+use strict;
+use Socket;
+
+$| = 1; # ensure test output is synchronous so processes don't conflict
+
+my $tcp = getprotobyname('tcp')
+    or skip_all("no tcp protocol available ($!)");
+my $udp = getprotobyname('udp')
+    or note "getprotobyname('udp') failed: $!";
+
+my $local = gethostbyname('localhost')
+    or note "gethostbyname('localhost') failed: $!";
+
+my $fork = $Config{d_fork} || $Config{d_pseudofork};
+
+{
+    # basic socket creation
+    socket(my $sock, PF_INET, SOCK_STREAM, $tcp)
+       or skip_all('socket() for tcp failed ($!), nothing else will work');
+    ok(close($sock), "close the socket");
+}
+
+SKIP: {
+    # test it all in TCP
+    $local or skip("No localhost", 2);
+
+    ok(socket(my $serv, PF_INET, SOCK_STREAM, $tcp), "make a tcp socket");
+    my $bind_at = pack_sockaddr_in(0, $local);
+    ok(bind($serv, $bind_at), "bind works")
+       or skip("Couldn't bind to localhost", 3);
+    my $bind_name = getsockname($serv);
+    ok($bind_name, "getsockname() on bound socket");
+    my ($bind_port) = unpack_sockaddr_in($bind_name);
+
+    print "# port $bind_port\n";
+
+  SKIP:
+    {
+       ok(listen($serv, 5), "listen() works")
+         or diag "listen error: $!";
+
+       $fork or skip("No fork", 1);
+       my $pid = fork;
+       my $send_data = "test" x 50_000;
+       if ($pid) {
+           # parent
+           ok(socket(my $accept, PF_INET, SOCK_STREAM, $tcp),
+              "make accept tcp socket");
+           ok(my $addr = accept($accept, $serv), "accept() works")
+               or diag "accept error: $!";
+
+           my $sent_total = 0;
+           while ($sent_total < length $send_data) {
+               my $sent = send($accept, substr($send_data, $sent_total), 0);
+               defined $sent or last;
+               $sent_total += $sent;
+           }
+           my $shutdown = shutdown($accept, 1);
+
+           # wait for the remote to close so data isn't lost in
+           # transit on a certain broken implementation
+           <$accept>;
+           # child tests are printed once we hit eof
+           curr_test(curr_test()+5);
+           waitpid($pid, 0);
+
+           ok($shutdown, "shutdown() works");
+       }
+       elsif (defined $pid) {
+           curr_test(curr_test()+2);
+           #sleep 1;
+           # child
+           ok_child(close($serv), "close server socket in child");
+           ok_child(socket(my $child, PF_INET, SOCK_STREAM, $tcp),
+              "make child tcp socket");
+
+           ok_child(connect($child, $bind_name), "connect() works")
+               or diag "connect error: $!";
+
+           my $buf;
+           my $recv_peer = recv($child, $buf, 1000, 0);
+           # [perl #118843]
+           ok_child($recv_peer eq '' || $recv_peer eq $bind_name,
+              "peer from recv() should be empty or the remote name");
+           while(defined recv($child, my $tmp, 1000, 0)) {
+               last if length $tmp == 0;
+               $buf .= $tmp;
+           }
+           is_child($buf, $send_data, "check we received the data");
+           close($child);
+           end_child();
+
+           exit(0);
+       }
+       else {
+           # failed to fork
+           diag "fork() failed $!";
+           skip("fork() failed", 1);
+       }
+    }
+}
+
+done_testing();
+
+my @child_tests;
+sub ok_child {
+    my ($ok, $note) = @_;
+    push @child_tests, ( $ok ? "ok " : "not ok ") . curr_test() . " - $note\n";
+    curr_test(curr_test()+1);
+}
+
+sub is_child {
+    my ($got, $want, $note) = @_;
+    ok_child($got eq $want, $note);
+}
+
+sub end_child {
+    print @child_tests;
+}