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 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    my $msg = Dumper($_[1]);
  38    $msg =~ s/\n\r/ /g;
  39    print $wtr "$msg\n";
  40    kill SIGUSR1 => $ppid if $ppid;
  41   };
  42   $SIG{__WARN__} = sub {
  43    my $warn = join '', @_;
  44    $warn =~ s/\n\r/ /g;
  45    print $wtr "!warn:$warn\n";
  46    kill SIGUSR1 => $ppid if $ppid;
  47   };
  48   print $wtr "!ok\n";
  49   pause while 1;
  50   exit EXIT_FAILURE;
  51  }
  52  close $wtr or die "close() failed: $!";
  53  my $t = <$rdr>;
  54  my $oldfh = select $rdr;
  55  $| = 1;
  56  select $oldfh;
  57 }
  58
  59 sub slaughter {
  60  if (defined $rdr) {
  61   close $rdr or die "close() falied: $!";
  62   undef $rdr;
  63  }
  64  if ($pid) {
  65   kill SIGKILL => $pid;
  66   waitpid $pid, 0;
  67   undef $pid;
  68  }
  69 }
  70
  71 sub respawn {
  72  warn "# respawn ($lives lives left)";
  73  slaughter;
  74  spawn;
  75 }
  76
  77 sub init {
  78  ($lives) = @_;
  79  $lives ||= 10;
  80  undef $pid;
  81  undef $rdr;
  82  spawn;
  83 }
  84
  85 sub cleanup { slaughter }
  86
  87 my $snd = new IPC::MorseSignals::Emitter;
  88
  89 sub try {
  90  my ($msg) = @_;
  91  my $speed = 2 ** 16;
  92  my $dump = Dumper($msg);
  93  1 while chomp $dump;
  94  $dump =~ s/\n\r/ /g;
  95  $snd->reset;
  96  my $len = 0;
  97  my $ok  = 0;
  98  while (!$ok && (($speed /= 2) >= 1)) {
  99   $snd->post($msg);
 100   $len = $snd->len;
 101   my $a = 1 + (int($len / $speed) || 1);
 102   last unless $a <= 20;
 103   $snd->speed($speed);
 104   my $r = '';
 105   eval {
 106    local $SIG{ALRM} = sub { die 'timeout' };
 107    local $SIG{__WARN__} = sub { $a = alarm 0; die 'do not want warnings' };
 108    alarm $a;
 109    $ready = 0;
 110    $snd->send($pid);
 111    pause until $ready;
 112    $r = <$rdr>;
 113    $a = alarm 0;
 114   };
 115   if (!defined $r) { # Something bad happened, respawn
 116    $snd->reset;
 117    respawn;
 118   } else {
 119    1 while chomp $r;
 120    if ($r eq $dump) {
 121     $ok = 1;
 122    } else {
 123 #    warn "# expected $dump, got $r";
 124 FLUSH:
 125     while ($r =~ /^!warn:(.*)/) {
 126      warn "# $1";
 127      warn "# flushing for $a seconds\n";
 128      eval {
 129       local $SIG{ALRM} = sub { die 'timeout' };
 130       alarm $a;
 131       $r = <$rdr>;
 132       $a = alarm 0;
 133      };
 134      if ($@) {
 135       $snd->reset;
 136       respawn;
 137       last FLUSH;
 138      }
 139     }
 140     sleep 1;
 141    }
 142   }
 143  }
 144  return $ok, $speed, $len;
 145 }
 146
 147 sub bench {
 148  my ($l, $n, $diag, $res) = @_;
 149  my $speed = 2 ** 16;
 150  my $ok = 0;
 151  my @alpha = ('a' .. 'z');
 152  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 153  my $dump = Dumper($msg);
 154  1 while chomp $dump;
 155  $dump =~ s/\n\r/ /g;
 156  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
 157  while (($ok < $n) && (($speed /= 2) >= 1)) {
 158   $ok = 0;
 159   my $desc = "$desc_base at $speed bits/s";
 160   $diag->("try $desc...");
 161 TRY:
 162   for (1 .. $n) {
 163    $snd->post($msg);
 164    my $a = 1 + (int($snd->len / $speed) || 1);
 165    $snd->speed($speed);
 166    my $r = '';
 167    eval {
 168     local $SIG{ALRM} = sub { die 'timeout' };
 169     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
 170     alarm $a;
 171     $ready = 0;
 172     $snd->send($pid);
 173     pause until $ready;
 174     $r = <$rdr>;
 175     alarm 0;
 176    };
 177    if (!defined $r) { # Something bad happened, respawn
 178     $snd->reset;
 179     respawn;
 180     last TRY;
 181    } else {
 182     1 while chomp $r;
 183     if ($r eq $dump) {
 184      ++$ok;
 185     } else {
 186      while ($r =~ /^!warn:(.*)/) {
 187       warn "# $1";
 188       warn "# flushing for $a seconds\n";
 189       eval {
 190        local $SIG{ALRM} = sub { die 'timeout' };
 191        alarm $a;
 192        $r = <$rdr>;
 193        $a = alarm 0;
 194       };
 195       if ($@) {
 196        $snd->reset;
 197        respawn;
 198        last TRY;
 199       }
 200      }
 201     }
 202    }
 203   }
 204  }
 205  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 206  return ($ok == $n);
 207 }
 208
 209 1;