X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=blobdiff_plain;f=t%2Flib%2FIPC%2FMorseSignals%2FTestSuite.pm;h=31996bad2a39c01ae1ba8d3d8fd032d96c9f0fff;hp=e11025ba1c9ffdd057eccf2a6bffa5190659532c;hb=52788ca36ac91ee06506c5574a3ce5a6bea9ad81;hpb=ddcc7c395d570f0ea20a8e9a242fcbfcc0e49522

diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm
index e11025b..31996ba 100644
--- 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 SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+use POSIX qw/pause SIGKILL EXIT_FAILURE/;
 
 use IPC::MorseSignals::Emitter;
 use IPC::MorseSignals::Receiver;
@@ -17,6 +17,11 @@ $Data::Dumper::Indent = 0;
 
 my ($lives, $pid, $rdr);
 
+sub slaughter;
+local $SIG{INT} = sub { slaughter };
+
+sub diag { warn "# @_" }
+
 sub spawn {
  --$lives;
  die 'forked too many times' if $lives < 0;
@@ -29,24 +34,25 @@ sub spawn {
   close $rdr or die "close() failed: $!";
   select $wtr;
   $| = 1;
-  $SIG{__WARN__} = sub { print $wtr "!warn\n"; };
-  my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
-   print $wtr Dumper($_[1]), "\n";
+  my $rcv = IPC::MorseSignals::Receiver->new(\%SIG, done => sub {
+   my $msg = Dumper($_[1]);
+   $msg =~ s/\n\r/ /g;
+   print $wtr "$msg\n";
+  });
+  $SIG{__WARN__} = sub {
+   my $warn = join '', @_;
+   $warn =~ s/\n\r/ /g;
+   print $wtr "!warn:$warn\n";
   };
-  my $ppid = getppid;
-  $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid };
-  alarm 1;
-  $SIG{HUP}  = sub { alarm 0; $rcv->reset }; # We can reset the alarm here.
+  print $wtr "!ok\n";
   pause while 1;
   exit EXIT_FAILURE;
  }
- my $ready = 0;
- local $SIG{HUP} = sub { $ready = 1 };
- sleep 1 until $ready;
  close $wtr or die "close() failed: $!";
  my $oldfh = select $rdr;
  $| = 1;
  select $oldfh;
+ my $t = <$rdr>;
 }
 
 sub slaughter {
@@ -54,15 +60,22 @@ sub slaughter {
   close $rdr or die "close() falied: $!";
   undef $rdr;
  }
- if (defined $pid) {
-  kill SIGINT  => $pid;
-  kill SIGTERM => $pid;
+ if ($pid) {
   kill SIGKILL => $pid;
-  waitpid $pid, 0;
+  my $kid;
+  do {
+   $kid = waitpid $pid, 0;
+  } while ($kid != $pid && $kid != -1);
   undef $pid;
  }
 }
 
+sub respawn {
+ diag "respawn ($lives lives left)";
+ slaughter;
+ spawn;
+}
+
 sub init {
  ($lives) = @_;
  $lives ||= 10;
@@ -73,86 +86,79 @@ sub init {
 
 sub cleanup { slaughter }
 
-my $snd = new IPC::MorseSignals::Emitter;
+my $snd = IPC::MorseSignals::Emitter->new;
 
 sub try {
  my ($msg) = @_;
- my $speed = 2 ** 16;
- my $ok = 0;
- my @ret;
- while (!$ok && (($speed /= 2) >= 1)) {
+ my $speed = 2 ** 10;
+ my $dump = Dumper($msg);
+ 1 while chomp $dump;
+ $dump =~ s/\n\r/ /g;
+ $snd->reset;
+ my $len = 0;
+ while (($speed /= 2) >= 1) {
+  $snd->post($msg);
+  $len = $snd->len;
+  my $a = 1 + (int($len / $speed) || 1);
+  last unless $a <= 20;
+  $snd->speed($speed);
   my $r = '';
-  my $dump = Dumper($msg);
-  1 while chomp $dump;
   eval {
    local $SIG{ALRM} = sub { die 'timeout' };
-   local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
-   my $a = (int(100 * (3 * length $msg) / $speed) || 1);
-   $a = 10 if $a > 10;
+   local $SIG{__WARN__} = sub { $a = alarm 0; die 'do not want warnings' };
    alarm $a;
-   kill SIGHUP => $pid;
-   $snd->post($msg);
-   $snd->speed($speed);
    $snd->send($pid);
    $r = <$rdr>;
-   alarm 0;
+   $a = alarm 0;
   };
-  if (!defined $r) { # Something bad happened, respawn
-   slaughter;
-   spawn;
-  } else {
+  if (defined $r) {
    1 while chomp $r;
-   if ($r eq $dump) {
-    $ok = 1;
-   } else {
-    kill SIGHUP => $pid;
-   }
+   return 1, $speed, $len if $r eq $dump;
   }
+  $snd->reset;
+  respawn;
  }
- return ($ok) ? $speed : 0;
+ 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');
  my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
  my $dump = Dumper($msg);
+ 1 while chomp $dump;
+ $dump =~ s/\n\r/ /g;
  my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
  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);
+   my $a = 1 + (int($snd->len / $speed) || 1);
+   $snd->speed($speed);
    my $r = '';
    eval {
     local $SIG{ALRM} = sub { die 'timeout' };
     local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
-    my $a = (int(100 * (3 * $l) / $speed) || 1);
-    $a = 10 if $a > 10;
     alarm $a;
-    kill SIGHUP => $pid;
-    $snd->post($msg);
-    $snd->speed($speed);
     $snd->send($pid);
     $r = <$rdr>;
     alarm 0;
    };
-   if (!defined $r) { # Something bad happened, respawn
-    slaughter;
-    spawn;
-    last TRY;
-   } else {
+   if (defined $r) {
     1 while chomp $r;
     if ($r eq $dump) {
      ++$ok;
-    } else {
-     kill SIGHUP => $pid;
-     last TRY;
+     next TRY;
     }
    }
+   $snd->reset;
+   respawn;
+   last TRY;
   }
  }
  push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');