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;
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;
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 {
}
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;
}
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);
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');
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);
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');