t/lib/IPC/MorseSignals/TestSuite.pm

   1 package IPC::MorseSignals::TestSuite;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dumper;
   7 use POSIX qw/pause SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
   8
   9 use IPC::MorseSignals::Emitter;
  10 use IPC::MorseSignals::Receiver;
  11
  12 use base qw/Exporter/;
  13
  14 our @EXPORT_OK = qw/try bench init cleanup/;
  15
  16 $Data::Dumper::Indent = 0;
  17
  18 my ($lives, $pid, $rdr);
  19
  20 sub spawn {
  21  --$lives;
  22  die 'forked too many times' if $lives < 0;
  23  pipe $rdr, my $wtr or die "pipe() failed: $!";
  24  $pid = fork;
  25  if (!defined $pid) {
  26   die "fork() failed: $!";
  27  } elsif ($pid == 0) {
  28   local %SIG;
  29   close $rdr or die "close() failed: $!";
  30   select $wtr;
  31   $| = 1;
  32   $SIG{__WARN__} = sub { print $wtr "!warn\n"; };
  33   my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
  34    print $wtr Dumper($_[1]), "\n";
  35   };
  36   my $ppid = getppid;
  37   $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid };
  38   alarm 1;
  39   $SIG{HUP}  = sub { alarm 0; $rcv->reset }; # We can reset the alarm here.
  40   pause 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 my $snd = new IPC::MorseSignals::Emitter;
  77
  78 sub try {
  79  my ($msg) = @_;
  80  my $speed = 2 ** 16;
  81  my $ok = 0;
  82  my @ret;
  83  while (!$ok && (($speed /= 2) >= 1)) {
  84   my $r = '';
  85   my $dump = Dumper($msg);
  86   1 while chomp $dump;
  87   eval {
  88    local $SIG{ALRM} = sub { die 'timeout' };
  89    local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
  90    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  91    $a = 10 if $a > 10;
  92    alarm $a;
  93    kill SIGHUP => $pid;
  94    $snd->post($msg);
  95    $snd->speed($speed);
  96    $snd->send($pid);
  97    $r = <$rdr>;
  98    alarm 0;
  99   };
 100   if (!defined $r) { # Something bad happened, respawn
 101    slaughter;
 102    spawn;
 103   } else {
 104    1 while chomp $r;
 105    if ($r eq $dump) {
 106     $ok = 1;
 107    } else {
 108     kill SIGHUP => $pid;
 109    }
 110   }
 111  }
 112  return ($ok) ? $speed : 0;
 113 }
 114
 115 sub bench {
 116  my ($l, $n, $diag, $res) = @_;
 117  my $speed = 2 ** 16;
 118  my $ok = 0;
 119  my @alpha = ('a' .. 'z');
 120  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 121  my $dump = Dumper($msg);
 122  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
 123  while (($ok < $n) && (($speed /= 2) >= 1)) {
 124   $ok = 0;
 125   my $desc = "$desc_base at $speed bits/s";
 126   $diag->("try $desc...");
 127 TRY:
 128   for (1 .. $n) {
 129    my $r = '';
 130    eval {
 131     local $SIG{ALRM} = sub { die 'timeout' };
 132     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
 133     my $a = (int(100 * (3 * $l) / $speed) || 1);
 134     $a = 10 if $a > 10;
 135     alarm $a;
 136     kill SIGHUP => $pid;
 137     $snd->post($msg);
 138     $snd->speed($speed);
 139     $snd->send($pid);
 140     $r = <$rdr>;
 141     alarm 0;
 142    };
 143    if (!defined $r) { # Something bad happened, respawn
 144     slaughter;
 145     spawn;
 146     last TRY;
 147    } else {
 148     1 while chomp $r;
 149     if ($r eq $dump) {
 150      ++$ok;
 151     } else {
 152      kill SIGHUP => $pid;
 153      last TRY;
 154     }
 155    }
 156   }
 157  }
 158  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 159  return ($ok == $n);
 160 }
 161
 162 1;