t/13-speed.t

   1 #!perl -T
   2
   3 use Test::More tests => 10;
   4
   5 use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_SUCCESS EXIT_FAILURE/;
   6
   7 use IPC::MorseSignals qw/msend mrecv mreset/;
   8
   9 my $lives = 10;
  10
  11 sub spawn {
  12  --$lives;
  13  die 'forked too many times' if $lives < 0;
  14  pipe my $rdr, my $wtr or die "pipe() failed: $!";
  15  my $pid = fork;
  16  if (!defined $pid) {
  17   die "fork() failed: $!";
  18  } elsif ($pid == 0) {
  19   close $rdr or die "close() failed: $!";
  20   my $block = 0;
  21   my $s = mrecv local %SIG, cb => sub {
  22    if ($block) {
  23     $block = 0;
  24    } else {
  25     select $wtr; $| = 1;
  26     print $wtr $_[1], "\n";
  27     select $wtr; $| = 1;
  28    }
  29   };
  30   $SIG{HUP} = sub { mreset $s };
  31   $SIG{__WARN__} = sub { $block = 1; };
  32   1 while 1;
  33   exit EXIT_FAILURE;
  34  }
  35  close $wtr or die "close() failed: $!";
  36  return ($pid, $rdr);
  37 }
  38
  39 sub slaughter {
  40  my ($pid) = @_;
  41  kill SIGINT  => $pid;
  42  kill SIGTERM => $pid;
  43  kill SIGKILL => $pid;
  44  waitpid $pid, 0;
  45 }
  46
  47 my @res;
  48
  49 my ($pid, $rdr) = spawn;
  50
  51 sub tryspeed {
  52  my ($l, $n) = @_;
  53  my $speed = 2 ** 16;
  54  my $ok = 0;
  55  my @alpha = ('a' .. 'z');
  56  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
  57  my $desc_base = "$l bytes sent $n times";
  58  while (($ok < $n) && (($speed /= 2) >= 1)) {
  59   my $desc = "$desc_base at $speed bits/s";
  60   diag("try $desc...");
  61 TRY:
  62   for (1 .. $n) {
  63    my $r = '';
  64    eval {
  65     local $SIG{ALRM} = sub { die 'timeout' };
  66     local $SIG{__WARN__} = sub { die 'do not want warnings' };
  67     my $a = (int(100 * (3 * $l) / $speed) || 1);
  68     $a = 10 if $a > 10;
  69     alarm $a;
  70     kill SIGHUP => $pid;
  71     msend $msg => $pid, speed => $speed;
  72     $r = <$rdr>;
  73    };
  74    kill SIGHUP => $pid if $@;
  75    alarm 0;
  76    if (!defined $r) { # Something bad happened, respawn
  77     close $rdr or die "close() failed: $!";
  78     slaughter $pid;
  79     ($pid, $rdr) = spawn;
  80     redo TRY;         # Retry this send
  81    } else {
  82     chomp $r;
  83     if ($r eq $msg) {
  84      ++$ok;
  85     } else {
  86      kill SIGHUP => $pid;
  87      last TRY;
  88     }
  89    }
  90   }
  91  }
  92  ok($ok >= $n, $desc_base);
  93  push @res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
  94 }
  95
  96 tryspeed 4,   1;
  97 tryspeed 4,   4;
  98 tryspeed 4,   16;
  99 tryspeed 4,   64;
 100 tryspeed 16,  1;
 101 tryspeed 16,  4;
 102 tryspeed 16,  16;
 103 tryspeed 64,  1;
 104 tryspeed 64,  4;
 105 tryspeed 256, 1;
 106
 107 slaughter $pid;
 108
 109 diag '=== Summary ===';
 110 diag $_ for sort {
 111  my ($l1, $n1) = $a =~ /(\d+)\D+(\d+)/;
 112  my ($l2, $n2) = $b =~ /(\d+)\D+(\d+)/;
 113  $l1 <=> $l2 || $n1 <=> $n2
 114 } @res;