t/lib/IPC/MorseSignals/TestSuite.pm

   1 package IPC::MorseSignals::TestSuite;
   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   select $wtr;
  28   $| = 1;
  29   $SIG{__WARN__} = sub { print $wtr "!warn\n"; };
  30   my $rcv = mrecv %SIG, cb => sub {
  31    my $is_utf8 = Encode::is_utf8($_[1]);
  32    binmode $wtr, ':utf8' if $is_utf8;
  33    print $wtr $_[0], ':', $_[1], "\n";
  34    binmode $wtr, ':crlf' if $is_utf8;
  35   };
  36   my $ppid = getppid;
  37   $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid };
  38   alarm 1;
  39   $SIG{HUP}  = sub { alarm 0; mreset $rcv }; # We can reset the alarm here.
  40   1 while 1;
  41   exit EXIT_FAILURE;
  42  }
  43  my $ready = 0;
  44  local $SIG{HUP} = sub { $ready = 1 };
  45  sleep 1 until $ready;
  46  close $wtr or die "close() failed: $!";
  47  my $oldfh = select $rdr;
  48  $| = 1;
  49  select $oldfh;
  50 }
  51
  52 sub slaughter {
  53  if (defined $rdr) {
  54   close $rdr or die "close() falied: $!";
  55   undef $rdr;
  56  }
  57  if (defined $pid) {
  58   kill SIGINT  => $pid;
  59   kill SIGTERM => $pid;
  60   kill SIGKILL => $pid;
  61   waitpid $pid, 0;
  62   undef $pid;
  63  }
  64 }
  65
  66 sub init {
  67  ($lives) = @_;
  68  $lives ||= 10;
  69  undef $pid;
  70  undef $rdr;
  71  spawn;
  72 }
  73
  74 sub cleanup { slaughter }
  75
  76 sub try {
  77  my ($msg, $sign) = @_;
  78  $sign ||= 0;
  79  my $speed = 2 ** 16;
  80  my $ok = 0;
  81  my @ret;
  82  binmode $rdr, ((Encode::is_utf8 $msg) ? ':utf8' : ':crlf');
  83  while (!$ok && (($speed /= 2) >= 1)) {
  84   my $r = '';
  85   eval {
  86    local $SIG{ALRM} = sub { die 'timeout' };
  87    local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
  88    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  89    $a = 10 if $a > 10;
  90    alarm $a;
  91    kill SIGHUP => $pid;
  92    msend $msg => $pid, speed => $speed, sign => $sign;
  93    $r = <$rdr>;
  94    alarm 0;
  95   };
  96   if (!defined $r) { # Something bad happened, respawn
  97    slaughter;
  98    spawn;
  99   } else {
 100    chomp $r;
 101    if ($r eq ((($sign) ? $$ : 0) . ':' . $msg)) {
 102     $ok = 1;
 103    } else {
 104     kill SIGHUP => $pid;
 105    }
 106   }
 107  }
 108  return ($ok) ? $speed : 0;
 109 }
 110
 111 sub speed {
 112  my ($l, $n, $diag, $res) = @_;
 113  my $speed = 2 ** 16;
 114  my $ok = 0;
 115  my @alpha = ('a' .. 'z');
 116  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 117  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
 118  while (($ok < $n) && (($speed /= 2) >= 1)) {
 119   $ok = 0;
 120   my $desc = "$desc_base at $speed bits/s";
 121   $diag->("try $desc...");
 122 TRY:
 123   for (1 .. $n) {
 124    my $r = '';
 125    eval {
 126     local $SIG{ALRM} = sub { die 'timeout' };
 127     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
 128     my $a = (int(100 * (3 * $l) / $speed) || 1);
 129     $a = 10 if $a > 10;
 130     alarm $a;
 131     kill SIGHUP => $pid;
 132     msend $msg => $pid, speed => $speed, sign => 0;
 133     $r = <$rdr>;
 134     alarm 0;
 135    };
 136    if (!defined $r) { # Something bad happened, respawn
 137     slaughter;
 138     spawn;
 139     last TRY;
 140    } else {
 141     chomp $r;
 142     if ($r eq '0:' . $msg) {
 143      ++$ok;
 144     } else {
 145      kill SIGHUP => $pid;
 146      last TRY;
 147     }
 148    }
 149   }
 150  }
 151  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 152  return ($ok == $n);
 153 }
 154
 155 1;