1 package IPC::MorseSignals::TestSuite;
7 use POSIX qw/pause SIGUSR1 SIGKILL EXIT_FAILURE/;
9 use IPC::MorseSignals::Emitter;
10 use IPC::MorseSignals::Receiver;
12 use base qw/Exporter/;
14 our @EXPORT_OK = qw/try bench init cleanup/;
16 $Data::Dumper::Indent = 0;
18 my ($lives, $pid, $rdr);
21 $SIG{USR1} = sub { $ready = 1 };
25 die 'forked too many times' if $lives < 0;
26 pipe $rdr, my $wtr or die "pipe() failed: $!";
29 die "fork() failed: $!";
32 close $rdr or die "close() failed: $!";
36 my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
37 my $msg = Dumper($_[1]);
40 kill SIGUSR1 => $ppid if $ppid;
42 $SIG{__WARN__} = sub {
43 my $warn = join '', @_;
45 print $wtr "!warn:$warn\n";
46 kill SIGUSR1 => $ppid if $ppid;
52 close $wtr or die "close() failed: $!";
54 my $oldfh = select $rdr;
61 close $rdr or die "close() falied: $!";
72 warn "# respawn ($lives lives left)";
85 sub cleanup { slaughter }
87 my $snd = new IPC::MorseSignals::Emitter;
92 my $dump = Dumper($msg);
98 while (!$ok && (($speed /= 2) >= 1)) {
101 my $a = 1 + (int($len / $speed) || 1);
102 last unless $a <= 20;
106 local $SIG{ALRM} = sub { die 'timeout' };
107 local $SIG{__WARN__} = sub { $a = alarm 0; die 'do not want warnings' };
115 if (!defined $r) { # Something bad happened, respawn
123 # warn "# expected $dump, got $r";
125 while ($r =~ /^!warn:(.*)/) {
127 warn "# flushing for $a seconds\n";
129 local $SIG{ALRM} = sub { die 'timeout' };
144 return $ok, $speed, $len;
148 my ($l, $n, $diag, $res) = @_;
151 my @alpha = ('a' .. 'z');
152 my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
153 my $dump = Dumper($msg);
156 my $desc_base = "$l bytes sent $n time" . ('s' x ($n != 1));
157 while (($ok < $n) && (($speed /= 2) >= 1)) {
159 my $desc = "$desc_base at $speed bits/s";
160 $diag->("try $desc...");
164 my $a = 1 + (int($snd->len / $speed) || 1);
168 local $SIG{ALRM} = sub { die 'timeout' };
169 local $SIG{__WARN__} = sub { alarm 0; die 'do not want warnings' };
177 if (!defined $r) { # Something bad happened, respawn
186 while ($r =~ /^!warn:(.*)/) {
188 warn "# flushing for $a seconds\n";
190 local $SIG{ALRM} = sub { die 'timeout' };
205 push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');