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 SIGUSR1 SIGTSTP SIGKILL 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 my $ready = 0;
  21 $SIG{USR1} = sub { $ready = 1 };
  22
  23 sub spawn {
  24  --$lives;
  25  die 'forked too many times' if $lives < 0;
  26  pipe $rdr, my $wtr or die "pipe() failed: $!";
  27  $pid = fork;
  28  if (!defined $pid) {
  29   die "fork() failed: $!";
  30  } elsif ($pid == 0) {
  31   local %SIG;
  32   close $rdr or die "close() failed: $!";
  33   select $wtr;
  34   $| = 1;
  35   my $ppid = getppid;
  36   my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
  37    print $wtr Dumper($_[1]), "\n";
  38    kill SIGUSR1 => $ppid if $ppid;
  39   };
  40   $SIG{__WARN__} = sub {
  41    my $warn = join '', @_;
  42    $warn =~ s/\n\r/ /g;
  43    print $wtr "!warn : $warn\n";
  44    kill SIGUSR1 => $ppid if $ppid;
  45   };
  46   $SIG{TSTP} = sub {
  47    $rcv->reset;
  48    kill SIGUSR1 => $ppid if $ppid;
  49   };
  50   print $wtr "ok\n";
  51   pause while 1;
  52   exit EXIT_FAILURE;
  53  }
  54  close $wtr or die "close() failed: $!";
  55  my $oldfh = select $rdr;
  56  $| = 1;
  57  select $oldfh;
  58  my $t = <$rdr>;
  59 }
  60
  61 sub slaughter {
  62  if (defined $rdr) {
  63   close $rdr or die "close() falied: $!";
  64   undef $rdr;
  65  }
  66  if ($pid) {
  67   kill SIGKILL => $pid;
  68   waitpid $pid, 0;
  69   undef $pid;
  70  }
  71 }
  72
  73 sub init {
  74  ($lives) = @_;
  75  $lives ||= 10;
  76  undef $pid;
  77  undef $rdr;
  78  spawn;
  79 }
  80
  81 sub cleanup { slaughter }
  82
  83 my $snd = new IPC::MorseSignals::Emitter;
  84
  85 sub try {
  86  my ($msg) = @_;
  87  my $speed = 2 ** 16;
  88  my $ok = 0;
  89  my @ret;
  90  while (!$ok && (($speed /= 2) >= 1)) {
  91   my $r = '';
  92   my $dump = Dumper($msg);
  93   1 while chomp $dump;
  94   eval {
  95    local $SIG{ALRM} = sub { die 'timeout' };
  96    local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
  97    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  98    $a = 10 if $a > 10;
  99    alarm $a;
 100    $snd->post($msg);
 101    $snd->speed($speed);
 102    $ready = 0;
 103    $snd->send($pid);
 104    pause until $ready;
 105    $r = <$rdr>;
 106    alarm 0;
 107   };
 108   if (!defined $r) { # Something bad happened, respawn
 109    slaughter;
 110    spawn;
 111   } else {
 112    1 while chomp $r;
 113    if ($r eq $dump) {
 114     $ok = 1;
 115    } else {
 116     warn $1 if $r =~ /^warn\s*:\s*(.*)/;
 117     $ready = 0;
 118     kill SIGTSTP => $pid if $pid;
 119     pause until $ready;
 120    }
 121   }
 122  }
 123  return ($ok) ? $speed : 0;
 124 }
 125
 126 sub bench {
 127  my ($l, $n, $diag, $res) = @_;
 128  my $speed = 2 ** 16;
 129  my $ok = 0;
 130  my @alpha = ('a' .. 'z');
 131  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 132  my $dump = Dumper($msg);
 133  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
 134  while (($ok < $n) && (($speed /= 2) >= 1)) {
 135   $ok = 0;
 136   my $desc = "$desc_base at $speed bits/s";
 137   $diag->("try $desc...");
 138 TRY:
 139   for (1 .. $n) {
 140    my $r = '';
 141    eval {
 142     local $SIG{ALRM} = sub { die 'timeout' };
 143     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
 144     my $a = (int(100 * (3 * $l) / $speed) || 1);
 145     $a = 10 if $a > 10;
 146     alarm $a;
 147     $snd->post($msg);
 148     $snd->speed($speed);
 149     $ready = 0;
 150     $snd->send($pid);
 151     pause until $ready;
 152     $r = <$rdr>;
 153     alarm 0;
 154    };
 155    if (!defined $r) { # Something bad happened, respawn
 156     slaughter;
 157     spawn;
 158     last TRY;
 159    } else {
 160     1 while chomp $r;
 161     if ($r eq $dump) {
 162      ++$ok;
 163     } else {
 164      $ready = 0;
 165      kill SIGTSTP => $pid if $pid;
 166      pause until $ready;
 167      last TRY;
 168     }
 169    }
 170   }
 171  }
 172  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 173  return ($ok == $n);
 174 }
 175
 176 1;