X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=blobdiff_plain;f=t%2Flib%2FIPC%2FMorseSignals%2FTestSuite.pm;h=8052a8588e3536a866a14a5fde9b946b5d29f558;hp=8e5900d360de6d29fe7685a4c0c60699b9e2debb;hb=db7266fa5be4347aac1d32a994d6529c7b5a4afb;hpb=66395d4fefdc940dce749d571e5c8106f682eca4

diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm
index 8e5900d..8052a85 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 SIGUSR1 SIGTSTP SIGKILL EXIT_FAILURE/;
+use POSIX qw/pause SIGUSR1 SIGKILL EXIT_FAILURE/;
 
 use IPC::MorseSignals::Emitter;
 use IPC::MorseSignals::Receiver;
@@ -34,28 +34,26 @@ sub spawn {
   $| = 1;
   my $ppid = getppid;
   my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
-   print $wtr Dumper($_[1]), "\n";
+   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";
+   print $wtr "!warn:$warn\n";
    kill SIGUSR1 => $ppid if $ppid;
   };
-  $SIG{TSTP} = sub {
-   $rcv->reset;
-   kill SIGUSR1 => $ppid if $ppid;
-  };
-  print $wtr "ok\n";
+  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 {
@@ -70,6 +68,12 @@ sub slaughter {
  }
 }
 
+sub respawn {
+ warn "# respawn ($lives lives left)";
+ slaughter;
+ spawn;
+}
+
 sub init {
  ($lives) = @_;
  $lives ||= 10;
@@ -85,42 +89,59 @@ my $snd = new IPC::MorseSignals::Emitter;
 sub try {
  my ($msg) = @_;
  my $speed = 2 ** 16;
- my $ok = 0;
- my @ret;
+ 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)) {
+  $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;
-   $snd->post($msg);
-   $snd->speed($speed);
    $ready = 0;
    $snd->send($pid);
    pause until $ready;
    $r = <$rdr>;
-   alarm 0;
+   $a = alarm 0;
   };
   if (!defined $r) { # Something bad happened, respawn
-   slaughter;
-   spawn;
+   $snd->reset;
+   respawn;
   } else {
    1 while chomp $r;
    if ($r eq $dump) {
     $ok = 1;
    } else {
-    warn $1 if $r =~ /^warn\s*:\s*(.*)/;
-    $ready = 0;
-    kill SIGTSTP => $pid if $pid;
-    pause until $ready;
+#    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 ($ok) ? $speed : 0;
+ return $ok, $speed, $len;
 }
 
 sub bench {
@@ -130,6 +151,8 @@ sub bench {
  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;
@@ -137,15 +160,14 @@ sub bench {
   $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;
-    $snd->post($msg);
-    $snd->speed($speed);
     $ready = 0;
     $snd->send($pid);
     pause until $ready;
@@ -153,18 +175,29 @@ TRY:
     alarm 0;
    };
    if (!defined $r) { # Something bad happened, respawn
-    slaughter;
-    spawn;
+    $snd->reset;
+    respawn;
     last TRY;
    } else {
     1 while chomp $r;
     if ($r eq $dump) {
      ++$ok;
     } else {
-     $ready = 0;
-     kill SIGTSTP => $pid if $pid;
-     pause until $ready;
-     last TRY;
+     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;
+      }
+     }
     }
    }
   }