t/lib/IPCMTest.pm

   1 package IPCMTest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
   7
   8 use IPC::MorseSignals qw/msend mrecv mreset/;
   9
  10 use base qw/Exporter/;
  11
  12 our @EXPORT_OK = qw/try speed init cleanup/;
  13
  14 our $lives = 10;
  15
  16 my ($utf8, $pid, $rdr);
  17
  18 sub spawn {
  19  --$lives;
  20  die 'forked too many times' if $lives < 0;
  21  pipe $rdr, my $wtr or die "pipe() failed: $!";
  22  $pid = fork;
  23  if (!defined $pid) {
  24   die "fork() failed: $!";
  25  } elsif ($pid == 0) {
  26   close $rdr or die "close() failed: $!";
  27   binmode $wtr, ':utf8' if $utf8;
  28   my $block = 0;
  29   my $rcv = mrecv local %SIG, cb => sub {
  30    if ($block) {
  31     $block = 0;
  32    } else {
  33     select $wtr; $| = 1;
  34     print $wtr $_[0], ':', $_[1], "\n";
  35     select $wtr; $| = 1;
  36    }
  37   };
  38   $SIG{HUP} = sub { mreset $rcv };
  39   $SIG{__WARN__} = sub { $block = 1 };
  40   1 while 1;
  41   exit EXIT_FAILURE;
  42  }
  43  close $wtr or die "close() failed: $!";
  44  binmode $rdr, ':utf8' if $utf8;
  45 }
  46
  47 sub slaughter {
  48  kill SIGINT  => $pid;
  49  kill SIGTERM => $pid;
  50  kill SIGKILL => $pid;
  51  waitpid $pid, 0;
  52 }
  53
  54 sub init {
  55  $utf8 = $_[0] || 0;
  56  spawn;
  57 }
  58
  59 sub cleanup { slaughter }
  60
  61 sub try {
  62  my ($msg, $sign) = @_;
  63  $sign ||= 0;
  64  my $speed = 2 ** 16;
  65  my $ok = 0;
  66  my @ret;
  67  while (!$ok && (($speed /= 2) >= 1)) {
  68   my $r = '';
  69   eval {
  70    local $SIG{ALRM} = sub { die 'timeout' };
  71    local $SIG{__WARN__} = sub { die 'do not want warnings' };
  72    my $a = (int(100 * (3 * length $msg) / $speed) || 1);
  73    $a = 10 if $a > 10;
  74    alarm $a;
  75    kill SIGHUP => $pid;
  76    msend $msg => $pid, speed => $speed, utf8 => $utf8, sign => $sign;
  77    $r = <$rdr>;
  78   };
  79   kill SIGHUP => $pid if $@;
  80   alarm 0;
  81   if (!defined $r) { # Something bad happened, respawn
  82    close $rdr or die "close() failed: $!";
  83    slaughter;
  84    spawn;
  85    $speed *= 2;      # Retry this speed
  86   } else {
  87    chomp $r;
  88    if ($r eq ((($sign) ? $$ : 0) . ':' . $msg)) {
  89     $ok = 1;
  90    } else {
  91     kill SIGHUP => $pid;
  92    }
  93   }
  94  }
  95  return ($ok) ? $speed : 0;
  96 }
  97
  98 sub speed {
  99  my ($l, $n, $diag, $res) = @_;
 100  my $speed = 2 ** 16;
 101  my $ok = 0;
 102  my @alpha = ('a' .. 'z');
 103  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
 104  my $desc_base = "$l bytes sent $n times";
 105  while (($ok < $n) && (($speed /= 2) >= 1)) {
 106   my $desc = "$desc_base at $speed bits/s";
 107   $diag->("try $desc...");
 108 TRY:
 109   for (1 .. $n) {
 110    my $r = '';
 111    eval {
 112     local $SIG{ALRM} = sub { die 'timeout' };
 113     local $SIG{__WARN__} = sub { die 'do not want warnings' };
 114     my $a = (int(100 * (3 * $l) / $speed) || 1);
 115     $a = 10 if $a > 10;
 116     alarm $a;
 117     kill SIGHUP => $pid;
 118     msend $msg => $pid, speed => $speed, utf8 => $utf8, sign => 0;
 119     $r = <$rdr>;
 120    };
 121    kill SIGHUP => $pid if $@;
 122    alarm 0;
 123    if (!defined $r) { # Something bad happened, respawn
 124     close $rdr or die "close() failed: $!";
 125     slaughter;
 126     spawn;
 127     redo TRY;         # Retry this send
 128    } else {
 129     chomp $r;
 130     if ($r eq '0:' . $msg) {
 131      ++$ok;
 132     } else {
 133      kill SIGHUP => $pid;
 134      last TRY;
 135     }
 136    }
 137   }
 138  }
 139  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
 140  return ($ok == $n);
 141 }
 142
 143 1;