ext/Socket/socketpair.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require Config; import Config;
   7     if ($Config{'extensions'} !~ /\bSocket\b/ &&
   8         !(($^O eq 'VMS') && $Config{d_socket})) {
   9         print "1..0\n";
  10         exit 0;
  11     }
  12 }
  13
  14 use Socket;
  15 use Test::More;
  16 use strict;
  17 use warnings;
  18
  19 my $skip_reason;
  20
  21 if( !$Config{d_alarm} ) {
  22   plan skip_all => "alarm() not implemented on this platform";
  23 } else {
  24   # This should fail but not die if there is real socketpair
  25   eval {socketpair LEFT, RIGHT, -1, -1, -1};
  26   if ($@ =~ /^Unsupported socket function "socketpair" called/) {
  27     plan skip_all => 'No socketpair (real or emulated)';
  28   } else {
  29     eval {AF_UNIX};
  30     if ($@ =~ /^Your vendor has not defined Socket macro AF_UNIX/) {
  31       plan skip_all => 'No AF_UNIX';
  32     } else {
  33       plan tests => 42;
  34     }
  35   }
  36 }
  37
  38 # Too many things in this test will hang forever if something is wrong, so
  39 # we need a self destruct timer.
  40 $SIG{ALRM} = sub {die "Something unexpectedly hung during testing"};
  41 alarm(60);
  42
  43 ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC),
  44     "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)")
  45   or print "# \$\! = $!";
  46
  47 my @left = ("hello ", "world\n");
  48 my @right = ("perl ", "rules!"); # Not like I'm trying to bias any survey here.
  49
  50 foreach (@left) {
  51   # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left");
  52   is (syswrite (LEFT, $_), length $_, "syswrite to left");
  53 }
  54 foreach (@right) {
  55   # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right");
  56   is (syswrite (RIGHT, $_), length $_, "syswrite to right");
  57 }
  58
  59 # stream socket, so our writes will become joined:
  60 my ($buffer, $expect);
  61 $expect = join '', @right;
  62 is (read (LEFT, $buffer, length $expect), length $expect, "read on left");
  63 is ($buffer, $expect, "content what we expected?");
  64 $expect = join '', @left;
  65 is (read (RIGHT, $buffer, length $expect), length $expect, "read on right");
  66 is ($buffer, $expect, "content what we expected?");
  67
  68 ok (shutdown(LEFT, 1), "shutdown left for writing");
  69 # This will hang forever if eof is buggy.
  70 ok (eof RIGHT, "right is at EOF");
  71
  72 my @gripping = (chr 255, chr 127);
  73 foreach (@gripping) {
  74   is (syswrite (RIGHT, $_), length $_, "syswrite to right");
  75 }
  76
  77 ok (!eof LEFT, "left is not at EOF");
  78
  79 $expect = join '', @gripping;
  80 is (read (LEFT, $buffer, length $expect), length $expect, "read on left");
  81 is ($buffer, $expect, "content what we expected?");
  82
  83 ok (close LEFT, "close left");
  84 ok (close RIGHT, "close right");
  85
  86 # And now datagrams
  87 # I suspect we also need a self destruct time-bomb for these, as I don't see any
  88 # guarantee that the stack won't drop a UDP packet, even if it is for localhost.
  89
  90 ok (socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC),
  91     "socketpair (LEFT, RIGHT, AF_UNIX, SOCK_DGRAM, PF_UNSPEC)")
  92   or print "# \$\! = $!";
  93
  94 foreach (@left) {
  95   # is (syswrite (LEFT, $_), length $_, "write " . _qq ($_) . " to left");
  96   is (syswrite (LEFT, $_), length $_, "syswrite to left");
  97 }
  98 foreach (@right) {
  99   # is (syswrite (RIGHT, $_), length $_, "write " . _qq ($_) . " to right");
 100   is (syswrite (RIGHT, $_), length $_, "syswrite to right");
 101 }
 102
 103 # stream socket, so our writes will become joined:
 104 my ($total);
 105 $total = join '', @right;
 106 foreach $expect (@right) {
 107   is (sysread (LEFT, $buffer, length $total), length $expect, "read on left");
 108   is ($buffer, $expect, "content what we expected?");
 109 }
 110 $total = join '', @left;
 111 foreach $expect (@left) {
 112   is (sysread (RIGHT, $buffer, length $total), length $expect, "read on right");
 113   is ($buffer, $expect, "content what we expected?");
 114 }
 115
 116 ok (shutdown(LEFT, 1), "shutdown left for writing");
 117 # eof uses buffering. eof is indicated by a sysread of zero.
 118 # but for a datagram socket there's no way it can know nothing will ever be
 119 # sent
 120 {
 121   my $alarmed = 0;
 122   local $SIG{ALRM} = sub { $alarmed = 1; };
 123   print "# Approximate forever as 3 seconds. Wait 'forever'...\n";
 124   alarm 3;
 125   is (sysread (RIGHT, $buffer, 1), undef,
 126       "read on right should be interrupted");
 127   is ($alarmed, 1, "alarm should have fired");
 128 }
 129 alarm 30;
 130
 131 #ok (eof RIGHT, "right is at EOF");
 132
 133 foreach (@gripping) {
 134   is (syswrite (RIGHT, $_), length $_, "syswrite to right");
 135 }
 136
 137 $total = join '', @gripping;
 138 foreach $expect (@gripping) {
 139   is (sysread (LEFT, $buffer, length $total), length $expect, "read on left");
 140   is ($buffer, $expect, "content what we expected?");
 141 }
 142
 143 ok (close LEFT, "close left");
 144 ok (close RIGHT, "close right");