From: Vincent Pit Date: Sun, 29 Jun 2008 16:37:20 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.15.tar.gz X-Git-Tag: v0.15^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=commitdiff_plain;h=9370c8d2ab07f434272dbbddb92bdd5d8d1fe3af Importing IPC-MorseSignals-0.15.tar.gz --- diff --git a/Changes b/Changes index 91a4f2b..4df4fe6 100644 --- a/Changes +++ b/Changes @@ -1,14 +1,21 @@ Revision history for IPC-MorseSignals -0.14 2008-03-13 +0.15 2008-04-05 00:00 UTC + 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. + + Fix : Strip off duplicated targets when sending to multiple processes + at the same time. + + Tst : Lower base speed to 1024 bauds when forking. + + Tst : Don't reset the receiver state anymore, but always respawn. + + Tst : t/70-speed.t tests are now marked as TODO, so that they won't + block module installation. + 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.14 + Phantom version, maybe released through CPAN for a short amount of time. + 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 d3ec65b..091322c 100644 --- a/META.yml +++ b/META.yml @@ -1,11 +1,11 @@ --- #YAML:1.0 name: IPC-MorseSignals -version: 0.14 +version: 0.15 abstract: Communicate between processes with Morse signals. license: perl author: - Vincent Pit -generated_by: ExtUtils::MakeMaker version 6.44 +generated_by: ExtUtils::MakeMaker version 6.42 distribution_type: module requires: Bit::MorseSignals: 0.05 diff --git a/Makefile.PL b/Makefile.PL index 9ee0b24..b9705a0 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -41,22 +41,22 @@ sub build_req { } WriteMakefile( - NAME => 'IPC::MorseSignals', - AUTHOR => 'Vincent Pit ', - LICENSE => 'perl', - VERSION_FROM => 'lib/IPC/MorseSignals.pm', - ABSTRACT_FROM => 'lib/IPC/MorseSignals.pm', - PL_FILES => {}, - PREREQ_PM => { + NAME => 'IPC::MorseSignals', + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => 'lib/IPC/MorseSignals.pm', + ABSTRACT_FROM => 'lib/IPC/MorseSignals.pm', + PL_FILES => {}, + PREREQ_PM => { 'Bit::MorseSignals' => 0.05, 'Carp' => 0, 'POSIX' => 0, 'Time::HiRes' => 0, }, - dist => { - PREOP => 'pod2text lib/IPC/MorseSignals.pm > $(DISTVNAME)/README; ' - . build_req, - COMPRESS => 'gzip -9f', SUFFIX => 'gz', + dist => { + PREOP => 'pod2text lib/IPC/MorseSignals.pm > $(DISTVNAME)/README; ' + . build_req, + COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, - clean => { FILES => 'IPC-MorseSignals-*' }, + clean => { FILES => 'IPC-MorseSignals-* *.gcov *.gcda *.gcno cover_db' }, ); diff --git a/README b/README index 119ef39..698de28 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME IPC::MorseSignals - Communicate between processes with Morse signals. VERSION - Version 0.14 + Version 0.15 SYNOPSIS # In the sender process diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm index f4e96e8..2de81ed 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.14 +Version 0.15 =cut -our $VERSION = '0.14'; +our $VERSION = '0.15'; =head1 SYNOPSIS diff --git a/lib/IPC/MorseSignals/Emitter.pm b/lib/IPC/MorseSignals/Emitter.pm index 7e2dca0..2b8a72a 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.14 +Version 0.15 =cut -our $VERSION = '0.14'; +our $VERSION = '0.15'; =head1 SYNOPSIS @@ -45,7 +45,7 @@ sub _check_self { =head2 C<< new < delay => $seconds, speed => $bauds, %bme_options > >> -Creates a new emitter object. C specifies the delay between two sends, in seconds, while C is the number of bits sent per second. The delay value has priority over the speed. Extra arguments are passed to L. +Creates a new emitter object. C specifies the delay between two sends, in seconds, while C is the number of bits sent per second. The delay value has priority over the speed. Default delay is 1 second. Extra arguments are passed to L. =cut @@ -68,7 +68,7 @@ sub new { =head2 C -Sends messages enqueued with L to the process C<$pid> (or to all the C<@$pid> if C<$pid> is an array reference). +Sends messages enqueued with L to the process C<$pid> (or to all the C<@$pid> if C<$pid> is an array reference, in which case duplicated targets are stripped off). =cut @@ -76,8 +76,10 @@ sub send { my ($self, $dest) = @_; _check_self($self); return unless defined $dest; - my @dests = grep $_ > 0, ref $dest eq 'ARRAY' ? map int, grep defined, @$dest - : int $dest; + my %count; + my @dests = grep $_ > 0 && !$count{$_}++, # Remove duplicates. + ref $dest eq 'ARRAY' ? map int, grep defined, @$dest + : int $dest; return unless @dests; while (defined(my $bit = $self->pop)) { my @sigs = (SIGUSR1, SIGUSR2); diff --git a/lib/IPC/MorseSignals/Receiver.pm b/lib/IPC/MorseSignals/Receiver.pm index 7bd1416..03d1945 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.14 +Version 0.15 =cut -our $VERSION = '0.14'; +our $VERSION = '0.15'; =head1 SYNOPSIS diff --git a/samples/bench.pl b/samples/bench.pl index 2f7daae..9bd146e 100755 --- a/samples/bench.pl +++ b/samples/bench.pl @@ -9,28 +9,29 @@ use lib qw{blib/lib t/lib}; use IPC::MorseSignals::TestSuite qw/init bench cleanup/; -my $diag = sub { print STDERR "@_\n" }; +sub diag { print STDERR "@_\n" }; +*IPC::MorseSignals::TestSuite::diag = *main::diag; my @res; init 100; -bench 4, 1, $diag, \@res; -bench 4, 4, $diag, \@res; -bench 4, 16, $diag, \@res; -bench 4, 64, $diag, \@res; -bench 4, 256, $diag, \@res; -bench 16, 1, $diag, \@res; -bench 16, 4, $diag, \@res; -bench 16, 16, $diag, \@res; -bench 16, 64, $diag, \@res; -bench 64, 1, $diag, \@res; -bench 64, 4, $diag, \@res; -bench 64, 16, $diag, \@res; -bench 256, 1, $diag, \@res; -bench 256, 4, $diag, \@res; -bench 1024, 1, $diag, \@res; +bench 4, 1, \@res; +bench 4, 4, \@res; +bench 4, 16, \@res; +bench 4, 64, \@res; +bench 4, 256, \@res; +bench 16, 1, \@res; +bench 16, 4, \@res; +bench 16, 16, \@res; +bench 16, 64, \@res; +bench 64, 1, \@res; +bench 64, 4, \@res; +bench 64, 16, \@res; +bench 256, 1, \@res; +bench 256, 4, \@res; +bench 1024, 1, \@res; cleanup; -print STDERR "=== Summary ===\n"; -print STDERR "$_\n" for @res; +diag "\n=== Summary ==="; +diag $_ for @res; diff --git a/t/10-sigusr.t b/t/10-sigusr.t index bfe2dc2..60b17b2 100644 --- a/t/10-sigusr.t +++ b/t/10-sigusr.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2; +use Test::More tests => 4; use POSIX qw/SIGUSR1 SIGUSR2/; @@ -13,7 +13,9 @@ local $SIG{'USR1'} = sub { ++$a }; local $SIG{'USR2'} = sub { ++$b }; kill SIGUSR1 => $$; -ok(($a == 1) && ($b == 0), 'SIGUSR1'); +is($a, 1, 'SIGUSR1 triggers $SIG{USR1}'); +is($b, 0, 'SIGUSR1 doesn\'t trigger $SIG{USR2}'); kill SIGUSR2 => $$; -ok(($a == 1) && ($b == 1), 'SIGUSR2'); +is($a, 1, 'SIGUSR2 doesn\'t trigger $SIG{USR1}'); +is($b, 1, 'SIGUSR2 triggers $SIG{USR2}'); diff --git a/t/20-emitter-obj.t b/t/20-emitter-obj.t index 97204fe..bd88b12 100644 --- a/t/20-emitter-obj.t +++ b/t/20-emitter-obj.t @@ -7,9 +7,11 @@ use Test::More tests => 19; use IPC::MorseSignals::Emitter; +sub neq { abs($_[0] - $_[1]) < ($_[1] / 10) }; + my $deuce = new IPC::MorseSignals::Emitter; ok(defined $deuce, 'BME object is defined'); -ok(ref $deuce eq 'IPC::MorseSignals::Emitter', 'IME object is valid'); +is(ref $deuce, 'IPC::MorseSignals::Emitter', 'IME object is valid'); ok($deuce->isa('Bit::MorseSignals::Emitter'), 'IME is a BME'); my $fake = { }; @@ -19,33 +21,33 @@ ok($@ && $@ =~ /^First\s+argument/, "IME methods only apply to IME objects"); eval { Bit::MorseSignals::Emitter::reset($fake) }; ok($@ && $@ =~ /^First\s+argument/, "BME methods only apply to BME objects"); -ok($deuce->delay == 1, 'default delay is 1'); -ok($deuce->speed == 1, 'default speed is 1'); +is($deuce->delay, 1, 'default delay is 1'); +is($deuce->speed, 1, 'default speed is 1'); $deuce->delay(0.1); -ok(abs($deuce->delay - 0.1) < 0.01, 'set delay is 0.1'); -ok($deuce->speed == 10, 'resulting speed is 10'); +ok(neq($deuce->delay, 0.1), 'set delay is 0.1'); +is($deuce->speed, 10, 'resulting speed is 10'); $deuce->speed(100); -ok($deuce->speed == 100, 'set speed is 100'); -ok(abs($deuce->delay - 0.01) < 0.001, 'resulting speed is 0.01'); +is($deuce->speed, 100, 'set speed is 100'); +ok(neq($deuce->delay, 0.01), 'resulting speed is 0.01'); $deuce = new IPC::MorseSignals::Emitter delay => 0.25; -ok(abs($deuce->delay - 0.25) < 0.025, 'initial delay is 0.25'); -ok($deuce->speed == 4, 'resulting initial speed is 4'); +ok(neq($deuce->delay, 0.25), 'initial delay is 0.25'); +is($deuce->speed, 4, 'resulting initial speed is 4'); $deuce = new IPC::MorseSignals::Emitter speed => 40; -ok($deuce->speed == 40, 'initial speed is 40'); -ok(abs($deuce->delay - 0.025) < 0.0025, 'resulting initial delay is 0.025'); +is($deuce->speed, 40, 'initial speed is 40'); +ok(neq($deuce->delay, 0.025), 'resulting initial delay is 0.025'); $deuce = new IPC::MorseSignals::Emitter delay => 0.25, speed => 40; -ok(abs($deuce->delay - 0.25) < 0.025, 'delay supersedes speed'); +ok(neq($deuce->delay, 0.25), 'delay supersedes speed'); $deuce = new IPC::MorseSignals::Emitter delay => 0; -ok($deuce->delay == 1, 'wrong delay results in 1'); +is($deuce->delay, 1, 'wrong delay results in 1'); $deuce = new IPC::MorseSignals::Emitter speed => 0.1; -ok($deuce->delay == 1, 'wrong speed results in 1'); +is($deuce->delay, 1, 'wrong speed results in 1'); $deuce = new IPC::MorseSignals::Emitter delay => 0, speed => -0.1; -ok($deuce->delay == 1, 'wrong delay and speed result in 1'); +is($deuce->delay, 1, 'wrong delay and speed result in 1'); diff --git a/t/30-receiver-obj.t b/t/30-receiver-obj.t index a2e4f19..855a9d0 100644 --- a/t/30-receiver-obj.t +++ b/t/30-receiver-obj.t @@ -9,7 +9,7 @@ use IPC::MorseSignals::Receiver; my $pants = new IPC::MorseSignals::Receiver \%SIG; ok(defined $pants, 'IMR object is defined'); -ok(ref $pants eq 'IPC::MorseSignals::Receiver', 'IMR object is valid'); +is(ref $pants, 'IPC::MorseSignals::Receiver', 'IMR object is valid'); ok($pants->isa('Bit::MorseSignals::Receiver'), 'IMR is a BMR'); my $fake = { }; diff --git a/t/50-self-plain.t b/t/50-self-plain.t index d503113..06c0a60 100644 --- a/t/50-self-plain.t +++ b/t/50-self-plain.t @@ -14,7 +14,7 @@ my @msgs = qw/hlagh hlaghlaghlagh HLAGH HLAGHLAGHLAGH \x{0dd0}\x{00} my $deuce = new IPC::MorseSignals::Emitter speed => 1024; my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub { my $cur = shift @msgs; - ok($_[1] eq $cur, 'got ' . $_[1] . ', received ' . $cur) + is($_[1], $cur, "message correctly received"); }; $deuce->post($_) for @msgs; diff --git a/t/60-fork-plain.t b/t/60-fork-plain.t index 6d66cf9..043e99e 100644 --- a/t/60-fork-plain.t +++ b/t/60-fork-plain.t @@ -8,6 +8,8 @@ use Test::More tests => 7; use lib 't/lib'; use IPC::MorseSignals::TestSuite qw/try init cleanup/; +*IPC::MorseSignals::TestSuite::diag = *Test::More::diag; + sub test { my ($desc, @args) = @_; my ($res, $speed, $len); diff --git a/t/61-fork-utf8.t b/t/61-fork-utf8.t index 038beea..c2c9c34 100644 --- a/t/61-fork-utf8.t +++ b/t/61-fork-utf8.t @@ -10,6 +10,8 @@ use Test::More tests => 5; use lib 't/lib'; use IPC::MorseSignals::TestSuite qw/try init cleanup/; +*IPC::MorseSignals::TestSuite::diag = *Test::More::diag; + sub test { my ($desc, @args) = @_; my ($res, $speed, $len); diff --git a/t/62-fork-storable.t b/t/62-fork-storable.t index 9d6f658..56e36eb 100644 --- a/t/62-fork-storable.t +++ b/t/62-fork-storable.t @@ -10,6 +10,8 @@ use Test::More tests => 8; use lib 't/lib'; use IPC::MorseSignals::TestSuite qw/try init cleanup/; +*IPC::MorseSignals::TestSuite::diag = *Test::More::diag; + sub test { my ($desc, @args) = @_; my ($res, $speed, $len); diff --git a/t/70-speed.t b/t/70-speed.t index fc6f031..07dd767 100644 --- a/t/70-speed.t +++ b/t/70-speed.t @@ -5,19 +5,22 @@ use warnings; use utf8; -use Test::More tests => 3; +my $n; +use Test::More tests => 1 + ($n = 5); use lib 't/lib'; use IPC::MorseSignals::TestSuite qw/bench init cleanup/; -my $diag = sub { diag @_ }; +*IPC::MorseSignals::TestSuite::diag = *Test::More::diag; + my @res; -init 12; +init 2 * $n; -ok(bench(4, 1, $diag, \@res)); -ok(bench(4, 4, $diag, \@res)); -ok(bench(16, 1, $diag, \@res)); +TODO: { + local $TODO = 'This is just to give you a measure of which speed you should use'; + ok(bench(2 ** ($n - $_), 2 ** $_, \@res)) for 0 .. $n; +} cleanup; diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm index 8052a85..570fa27 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 SIGKILL EXIT_FAILURE/; +use POSIX qw/pause SIGKILL EXIT_FAILURE/; use IPC::MorseSignals::Emitter; use IPC::MorseSignals::Receiver; @@ -17,8 +17,10 @@ $Data::Dumper::Indent = 0; 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; @@ -32,28 +34,25 @@ sub spawn { 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 { @@ -63,13 +62,16 @@ 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; } @@ -88,14 +90,13 @@ my $snd = new IPC::MorseSignals::Emitter; 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); @@ -106,46 +107,22 @@ sub try { 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'); @@ -157,7 +134,7 @@ sub bench { 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); @@ -168,38 +145,20 @@ TRY: 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');