Importing IPC-MorseSignals-0.15.tar.gz

[perl/modules/IPC-MorseSignals.git] / t / lib / IPC / MorseSignals / TestSuite.pm

diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm
index 8052a8588e3536a866a14a5fde9b946b5d29f558..570fa2762f2254c2304146dbbacd7be8b7e8872f 100644 (file)
--- a/t/lib/IPC/MorseSignals/TestSuite.pm
+++ b/t/lib/IPC/MorseSignals/TestSuite.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 
 use Data::Dumper;
-use POSIX qw/pause SIGUSR1 SIGKILL EXIT_FAILURE/;
+use POSIX qw/pause SIGKILL EXIT_FAILURE/;
 
 use IPC::MorseSignals::Emitter;
 use IPC::MorseSignals::Receiver;
@@ -17,8 +17,10 @@ $Data::Dumper::Indent = 0;
 
 my ($lives, $pid, $rdr);
 
-my $ready = 0;
-$SIG{USR1} = sub { $ready = 1 };
+sub slaughter;
+local $SIG{INT} = sub { slaughter };
+
+sub diag { warn "# @_" }
 
 sub spawn {
  --$lives;
@@ -32,28 +34,25 @@ sub spawn {
   close $rdr or die "close() failed: $!";
   select $wtr;
   $| = 1;
-  my $ppid = getppid;
   my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
    my $msg = Dumper($_[1]);
    $msg =~ s/\n\r/ /g;
    print $wtr "$msg\n";
-   kill SIGUSR1 => $ppid if $ppid;
   };
   $SIG{__WARN__} = sub {
    my $warn = join '', @_;
    $warn =~ s/\n\r/ /g;
    print $wtr "!warn:$warn\n";
-   kill SIGUSR1 => $ppid if $ppid;
   };
   print $wtr "!ok\n";
   pause while 1;
   exit EXIT_FAILURE;
  }
  close $wtr or die "close() failed: $!";
- my $t = <$rdr>;
  my $oldfh = select $rdr;
  $| = 1;
  select $oldfh;
+ my $t = <$rdr>;
 }
 
 sub slaughter {
@@ -63,13 +62,16 @@ sub slaughter {
  }
  if ($pid) {
   kill SIGKILL => $pid;
-  waitpid $pid, 0;
+  my $kid;
+  do {
+   $kid = waitpid $pid, 0;
+  } while ($kid != $pid && $kid != -1);
   undef $pid;
  }
 }
 
 sub respawn {
- warn "# respawn ($lives lives left)";
+ diag "respawn ($lives lives left)";
  slaughter;
  spawn;
 }
@@ -88,14 +90,13 @@ my $snd = new IPC::MorseSignals::Emitter;
 
 sub try {
  my ($msg) = @_;
- my $speed = 2 ** 16;
+ my $speed = 2 ** 10;
  my $dump = Dumper($msg);
  1 while chomp $dump;
  $dump =~ s/\n\r/ /g; 
  $snd->reset;
  my $len = 0;
- my $ok  = 0;
- while (!$ok && (($speed /= 2) >= 1)) {
+ while (($speed /= 2) >= 1) {
   $snd->post($msg);
   $len = $snd->len;
   my $a = 1 + (int($len / $speed) || 1);
@@ -106,46 +107,22 @@ sub try {
    local $SIG{ALRM} = sub { die 'timeout' };
    local $SIG{__WARN__} = sub { $a = alarm 0; die 'do not want warnings' };
    alarm $a;
-   $ready = 0;
    $snd->send($pid);
-   pause until $ready;
    $r = <$rdr>;
    $a = alarm 0;
   };
-  if (!defined $r) { # Something bad happened, respawn
-   $snd->reset;
-   respawn;
-  } else {
+  if (defined $r) {
    1 while chomp $r;
-   if ($r eq $dump) {
-    $ok = 1;
-   } else {
-#    warn "# expected $dump, got $r";
-FLUSH:
-    while ($r =~ /^!warn:(.*)/) {
-     warn "# $1";
-     warn "# flushing for $a seconds\n";
-     eval {
-      local $SIG{ALRM} = sub { die 'timeout' };
-      alarm $a;
-      $r = <$rdr>;
-      $a = alarm 0;
-     };
-     if ($@) {
-      $snd->reset;
-      respawn;
-      last FLUSH;
-     }
-    }
-    sleep 1;
-   }
+   return 1, $speed, $len if $r eq $dump;
   }
+  $snd->reset;
+  respawn;
  }
- return $ok, $speed, $len;
+ return 0, $speed, $len;
 }
 
 sub bench {
- my ($l, $n, $diag, $res) = @_;
+ my ($l, $n, $res) = @_;
  my $speed = 2 ** 16;
  my $ok = 0;
  my @alpha = ('a' .. 'z');
@@ -157,7 +134,7 @@ sub bench {
  while (($ok < $n) && (($speed /= 2) >= 1)) {
   $ok = 0;
   my $desc = "$desc_base at $speed bits/s";
-  $diag->("try $desc...");
+  diag "try $desc...";
 TRY:
   for (1 .. $n) {
    $snd->post($msg);
@@ -168,38 +145,20 @@ TRY:
     local $SIG{ALRM} = sub { die 'timeout' };
     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
     alarm $a;
-    $ready = 0;
     $snd->send($pid);
-    pause until $ready;
     $r = <$rdr>;
     alarm 0;
    };
-   if (!defined $r) { # Something bad happened, respawn
-    $snd->reset;
-    respawn;
-    last TRY;
-   } else {
+   if (defined $r) {
     1 while chomp $r;
     if ($r eq $dump) {
      ++$ok;
-    } else {
-     while ($r =~ /^!warn:(.*)/) {
-      warn "# $1";
-      warn "# flushing for $a seconds\n";
-      eval {
-       local $SIG{ALRM} = sub { die 'timeout' };
-       alarm $a;
-       $r = <$rdr>;
-       $a = alarm 0;
-      };
-      if ($@) {
-       $snd->reset;
-       respawn;
-       last TRY;
-      }
-     }
+     next TRY;
     }
    }
+   $snd->reset;
+   respawn;
+   last TRY;
   }
  }
  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');