From: Vincent Pit Date: Sun, 29 Jun 2008 16:37:17 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.14.tar.gz X-Git-Tag: v0.14^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=commitdiff_plain;h=db7266fa5be4347aac1d32a994d6529c7b5a4afb Importing IPC-MorseSignals-0.14.tar.gz --- diff --git a/Changes b/Changes index 986fd7c..91a4f2b 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,14 @@ Revision history for IPC-MorseSignals +0.14 2008-03-13 + + Fix : Correct die error when SIGUSR{1,2} aren't found. + + Tst : Don't reset the receiver state, flush the pipe instead. + SIGTSTP isn't needed anymore. + + Tst : Timeouts aren't truncated to 10 seconds anymore. This used to + result into physically logical failures. On the other hand, if + the required timeout now goes over 20 seconds, the test is + considered failed. + 0.13 2008-03-10 15:25 UTC + Chg : Build prerequisites are now completely separated from run-time prerequisites. diff --git a/META.yml b/META.yml index c4bbd91..d3ec65b 100644 --- a/META.yml +++ b/META.yml @@ -1,6 +1,6 @@ --- #YAML:1.0 name: IPC-MorseSignals -version: 0.13 +version: 0.14 abstract: Communicate between processes with Morse signals. license: perl author: @@ -8,7 +8,7 @@ author: generated_by: ExtUtils::MakeMaker version 6.44 distribution_type: module requires: - Bit::MorseSignals: 0 + Bit::MorseSignals: 0.05 Carp: 0 POSIX: 0 Time::HiRes: 0 diff --git a/Makefile.PL b/Makefile.PL index f7ab125..9ee0b24 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -15,7 +15,7 @@ for (qw/USR1 USR2/) { print "Checking if you have SIG$_... "; unless (exists $sigs{$_}) { print "no\n"; - die 'OS unsupported' if $@; + die 'OS unsupported'; } print "yes\n"; } @@ -48,7 +48,7 @@ WriteMakefile( ABSTRACT_FROM => 'lib/IPC/MorseSignals.pm', PL_FILES => {}, PREREQ_PM => { - 'Bit::MorseSignals' => 0, + 'Bit::MorseSignals' => 0.05, 'Carp' => 0, 'POSIX' => 0, 'Time::HiRes' => 0, diff --git a/README b/README index 215ebed..119ef39 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME IPC::MorseSignals - Communicate between processes with Morse signals. VERSION - Version 0.13 + Version 0.14 SYNOPSIS # In the sender process diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm index 7cb3928..f4e96e8 100644 --- a/lib/IPC/MorseSignals.pm +++ b/lib/IPC/MorseSignals.pm @@ -9,11 +9,11 @@ IPC::MorseSignals - Communicate between processes with Morse signals. =head1 VERSION -Version 0.13 +Version 0.14 =cut -our $VERSION = '0.13'; +our $VERSION = '0.14'; =head1 SYNOPSIS diff --git a/lib/IPC/MorseSignals/Emitter.pm b/lib/IPC/MorseSignals/Emitter.pm index 940fd16..7e2dca0 100644 --- a/lib/IPC/MorseSignals/Emitter.pm +++ b/lib/IPC/MorseSignals/Emitter.pm @@ -16,11 +16,11 @@ IPC::MorseSignals::Emitter - Base class for IPC::MorseSignals emitters. =head1 VERSION -Version 0.13 +Version 0.14 =cut -our $VERSION = '0.13'; +our $VERSION = '0.14'; =head1 SYNOPSIS diff --git a/lib/IPC/MorseSignals/Receiver.pm b/lib/IPC/MorseSignals/Receiver.pm index 44a21b9..7bd1416 100644 --- a/lib/IPC/MorseSignals/Receiver.pm +++ b/lib/IPC/MorseSignals/Receiver.pm @@ -14,11 +14,11 @@ IPC::MorseSignals::Receiver - Base class for IPC::MorseSignals receivers. =head1 VERSION -Version 0.13 +Version 0.14 =cut -our $VERSION = '0.13'; +our $VERSION = '0.14'; =head1 SYNOPSIS diff --git a/t/60-fork-plain.t b/t/60-fork-plain.t index a65dde8..6d66cf9 100644 --- a/t/60-fork-plain.t +++ b/t/60-fork-plain.t @@ -10,8 +10,12 @@ use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; - eval { ok(try(@args), $desc) }; + my ($res, $speed, $len); + eval { + ($res, $speed, $len) = try(@args); + }; fail($desc . " (died : $@)") if $@; + ok($res, $desc . ' (' . $len . ' bits @ ' . $speed . ' bauds)'); } my @msgs = qw/hlagh hlaghlaghlagh HLAGH HLAGHLAGHLAGH \x{0dd0}\x{00} @@ -19,8 +23,8 @@ my @msgs = qw/hlagh hlaghlaghlagh HLAGH HLAGHLAGHLAGH \x{0dd0}\x{00} init 6; -for (0 .. $#msgs) { - test 'plain ' . $_ => $msgs[$_]; +for (1 .. @msgs) { + test 'plain ' . $_ => $msgs[$_-1]; } cleanup; diff --git a/t/61-fork-utf8.t b/t/61-fork-utf8.t index 29b1910..038beea 100644 --- a/t/61-fork-utf8.t +++ b/t/61-fork-utf8.t @@ -12,16 +12,20 @@ use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; - eval { ok(try(@args), $desc) }; + my ($res, $speed, $len); + eval { + ($res, $speed, $len) = try(@args); + }; fail($desc . " (died : $@)") if $@; + ok($res, $desc . ' (' . $len . ' bits @ ' . $speed . ' bauds)'); } my @msgs = qw/€éèë 月語 x tata たTÂ/; init 6; -for (0 .. $#msgs) { - test 'utf8 ' . $_ => $msgs[$_]; +for (1 .. @msgs) { + test 'utf8 ' . $_ => $msgs[$_-1]; } cleanup; diff --git a/t/62-fork-storable.t b/t/62-fork-storable.t index 6aafeeb..9d6f658 100644 --- a/t/62-fork-storable.t +++ b/t/62-fork-storable.t @@ -12,8 +12,12 @@ use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; - eval { ok(try(@args), $desc) }; + my ($res, $speed, $len); + eval { + ($res, $speed, $len) = try(@args); + }; fail($desc . " (died : $@)") if $@; + ok($res, $desc . ' (' . $len . ' bits @ ' . $speed . ' bauds)'); } my @msgs = ( @@ -26,8 +30,8 @@ $msgs[7]->{y} = $msgs[7]; init 6; -for (0 .. $#msgs) { - test 'storable ' . $_ => $msgs[$_]; +for (1 .. @msgs) { + test 'storable ' . $_ => $msgs[$_-1]; } cleanup; 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; + } + } } } }