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.
--- #YAML:1.0
name: IPC-MorseSignals
-version: 0.14
+version: 0.15
abstract: Communicate between processes with Morse signals.
license: perl
author:
- Vincent Pit <perl@profvince.com>
-generated_by: ExtUtils::MakeMaker version 6.44
+generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
Bit::MorseSignals: 0.05
}
WriteMakefile(
- NAME => 'IPC::MorseSignals',
- AUTHOR => 'Vincent Pit <perl@profvince.com>',
- LICENSE => 'perl',
- VERSION_FROM => 'lib/IPC/MorseSignals.pm',
- ABSTRACT_FROM => 'lib/IPC/MorseSignals.pm',
- PL_FILES => {},
- PREREQ_PM => {
+ NAME => 'IPC::MorseSignals',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ 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' },
);
IPC::MorseSignals - Communicate between processes with Morse signals.
VERSION
- Version 0.14
+ Version 0.15
SYNOPSIS
# In the sender process
=head1 VERSION
-Version 0.14
+Version 0.15
=cut
-our $VERSION = '0.14';
+our $VERSION = '0.15';
=head1 SYNOPSIS
=head1 VERSION
-Version 0.14
+Version 0.15
=cut
-our $VERSION = '0.14';
+our $VERSION = '0.15';
=head1 SYNOPSIS
=head2 C<< new < delay => $seconds, speed => $bauds, %bme_options > >>
-Creates a new emitter object. C<delay> specifies the delay between two sends, in seconds, while C<speed> is the number of bits sent per second. The delay value has priority over the speed. Extra arguments are passed to L<Bit::MorseSignals::Emitter/new>.
+Creates a new emitter object. C<delay> specifies the delay between two sends, in seconds, while C<speed> 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<Bit::MorseSignals::Emitter/new>.
=cut
=head2 C<send $pid>
-Sends messages enqueued with L<Bit::MorseSignals::Emitter/post> to the process C<$pid> (or to all the C<@$pid> if C<$pid> is an array reference).
+Sends messages enqueued with L<Bit::MorseSignals::Emitter/post> 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
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);
=head1 VERSION
-Version 0.14
+Version 0.15
=cut
-our $VERSION = '0.14';
+our $VERSION = '0.15';
=head1 SYNOPSIS
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;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 4;
use POSIX qw/SIGUSR1 SIGUSR2/;
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}');
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 = { };
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');
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 = { };
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;
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);
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);
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);
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;
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');