t/lib/IPCMTest.pm

   1 package IPCMTest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Encode;
   7 use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
   8
   9 use IPC::MorseSignals qw/msend mrecv mreset/;
  10
  11 use base qw/Exporter/;
  12
  13 our @EXPORT_OK = qw/try speed init cleanup/;
  14
  15 my ($lives, $pid, $rdr);
  16
  17 sub spawn {
  18  --$lives;
  19  die 'forked too many times' if $lives < 0;
  20  pipe $rdr, my $wtr or die "pipe() failed: $!";
  21  $pid = fork;
  22  if (!defined $pid) {
  23   die "fork() failed: $!";
  24  } elsif ($pid == 0) {
  25   local %SIG;
  26   close $rdr or die "close() failed: $!";
  27   my $rcv = mrecv %SIG, cb => sub {
  28    binmode $wtr, ':utf8' if Encode::is_utf8 $_[1];
  29    select $wtr; $| = 1;
  30    print $wtr $_[0], ':', $_[1], "\n";
  31    select $wtr; $| = 1;
  32   };
  33   $SIG{HUP} = sub { mreset $rcv };
  34   $SIG{__WARN__} = sub {
  35    select $wtr; $| = 1;
  36    print $wtr "__WARN__\n";
  37    select $wtr; $| = 1;
  38   };
  39   1 while 1;
  40   exit EXIT_FAILURE;
  41  }
  42  close $wtr or die "close() failed: $!";
  43 }
  44
  45 sub slaughter {
  46  kill SIGINT  => $pid;
  47  kill SIGTERM => $pid;
  48  kill SIGKILL => $pid;
  49  waitpid $pid, 0;
  50 }
  51
  52 sub init {
  53  ($lives) = @_;
  54  $lives ||= 10;
  55  spawn;
  56 }
  57
  58 sub cleanup { slaughter }
  59
  60 sub try {
  61  my ($msg, $sign) = @_;
  62  $sign ||= 0;
  63  my $speed = 2 ** 16;
  64  my $ok = 0;
  65  my @ret;
  66  binmode $rdr, ((Encode::is_utf8 $msg) ? ':utf8' : ':crlf');
  67  while (!$ok && (($speed /= 2) >= 1)) {
  68   my $r = '';
  69   eval {
  70    local $SIG{ALRM} = sub { die 'timeout' };
  71    local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
  72    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  73    $a = 10 if $a > 10;
  74    alarm $a;
  75    kill SIGHUP => $pid;
  76    msend $msg => $pid, speed => $speed, sign => $sign;
  77    $r = <$rdr>;
  78    alarm 0;
  79   };
  80   if (!defined $r) { # Something bad happened, respawn
  81    close $rdr or die "close() failed: $!";
  82    slaughter;
  83    spawn;
  84   } else {
  85    chomp $r;
  86    if ($r eq ((($sign) ? $$ : 0) . ':' . $msg)) {
  87     $ok = 1;
  88    } else {
  89     kill SIGHUP => $pid;
  90    }
  91   }
  92  }
  93  return ($ok) ? $speed : 0;
  94 }
  95
  96 sub speed {
  97  my ($l, $n, $diag, $res) = @_;
  98  my $speed = 2 ** 16;
  99  my $ok = 0;
 100  my @alpha = ('a' .. 'z');
 101  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 102  my $desc_base = "$l bytes sent $n times";
 103  while (($ok < $n) && (($speed /= 2) >= 1)) {
 104   $ok = 0;
 105   my $desc = "$desc_base at $speed bits/s";
 106   $diag->("try $desc...");
 107 TRY:
 108   for (1 .. $n) {
 109    my $r = '';
 110    eval {
 111     local $SIG{ALRM} = sub { die 'timeout' };
 112     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
 113     my $a = (int(100 * (3 * $l) / $speed) || 1);
 114     $a = 10 if $a > 10;
 115     alarm $a;
 116     kill SIGHUP => $pid;
 117     msend $msg => $pid, speed => $speed, sign => 0;
 118     $r = <$rdr>;
 119     alarm 0;
 120    };
 121    if (!defined $r) { # Something bad happened, respawn
 122     close $rdr or die "close() failed: $!";
 123     slaughter;
 124     spawn;
 125     last TRY;
 126    } else {
 127     chomp $r;
 128     if ($r eq '0:' . $msg) {
 129      ++$ok;
 130     } else {
 131      kill SIGHUP => $pid;
 132      last TRY;
 133     }
 134    }
 135   }
 136  }
 137  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 138  return ($ok == $n);
 139 }
 140
 141 1;