use warnings;
use Data::Dumper;
-use POSIX qw/pause SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+use POSIX qw/pause SIGUSR1 SIGKILL EXIT_FAILURE/;
use IPC::MorseSignals::Emitter;
use IPC::MorseSignals::Receiver;
my ($lives, $pid, $rdr);
+my $ready = 0;
+$SIG{USR1} = sub { $ready = 1 };
+
sub spawn {
--$lives;
die 'forked too many times' if $lives < 0;
close $rdr or die "close() failed: $!";
select $wtr;
$| = 1;
- $SIG{__WARN__} = sub { print $wtr "!warn\n"; };
+ 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;
};
- 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.
+ $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;
}
- my $ready = 0;
- local $SIG{HUP} = sub { $ready = 1 };
- sleep 1 until $ready;
close $wtr or die "close() failed: $!";
+ my $t = <$rdr>;
my $oldfh = select $rdr;
$| = 1;
select $oldfh;
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;
undef $pid;
}
}
+sub respawn {
+ warn "# respawn ($lives lives left)";
+ slaughter;
+ spawn;
+}
+
sub init {
($lives) = @_;
$lives ||= 10;
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;
- kill SIGHUP => $pid;
- $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 {
- kill SIGHUP => $pid;
+# 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 {
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;
$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);
+ $ready = 0;
$snd->send($pid);
+ pause until $ready;
$r = <$rdr>;
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 {
- kill SIGHUP => $pid;
- 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;
+ }
+ }
}
}
}