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