Revision history for IPC-MorseSignals
+0.07 2007-08-28 11:30 UTC
+ + Chg : Common test code was factored into a module.
+ + Chg : Tests were lightened again.
+ + Doc : Typos in POD.
+
0.06 2007-08-21 08:15 UTC
+ Add : The protocol now carries the UTF-8 flag (hence you no longer
need to specify it to mrecv()) and the sender's PID (but you can
t/kwalitee.t
t/pod-coverage.t
t/pod.t
+t/lib/IPCMTest.pm
--- #YAML:1.0
name: IPC-MorseSignals
-version: 0.06
+version: 0.07
abstract: Communicate between processes with Morse signals.
license: perl
generated_by: ExtUtils::MakeMaker version 6.36
distribution_type: module
requires:
Carp: 0
+ Exporter: 0
POSIX: 0
Test::More: 0
Time::HiRes: 0
PL_FILES => {},
PREREQ_PM => {
'Carp' => 0,
+ 'Exporter' => 0,
'POSIX' => 0,
'Test::More' => 0,
'Time::HiRes' => 0,
IPC::MorseSignals - Communicate between processes with Morse signals.
VERSION
- Version 0.06
+ Version 0.07
SYNOPSIS
use IPC::MorseSignals qw/msend mrecv/;
the callback to trigger each time a complete message has arrived.
Basically, you want to use it like this :
- my $rv = mrecv local %SIG, cb => sub { ... };
+ my $rcv = mrecv local %SIG, cb => sub { ... };
In the callback, $_[0] is the sender's PID (or 0 if the sender wanted to
stay anonymous) and $_[1] is the message received.
or false otherwise.
"mlastsender"
- mlastmsg $rcv
+ mlastsender $rcv
Holds the PID of the last process that sent data to the receiver $rcv, 0
if that process was anonymous, or "undef" if no message has arrived yet.
=head1 VERSION
-Version 0.06
+Version 0.07
=cut
-our $VERSION = '0.06';
+our $VERSION = '0.07';
=head1 SYNOPSIS
Takes as its first argument the C<%SIG> hash and returns a hash reference that represent the current state of the receiver. C<%SIG>'s fields C<'USR1'> and C<'USR2'> will be replaced by the receiver's callbacks. C<cb> specifies the callback to trigger each time a complete message has arrived. Basically, you want to use it like this :
- my $rv = mrecv local %SIG, cb => sub { ... };
+ my $rcv = mrecv local %SIG, cb => sub { ... };
In the callback, C<$_[0]> is the sender's PID (or C<0> if the sender wanted to stay anonymous) and C<$_[1]> is the message received.
sub mreset {
my ($rcv) = @_;
+ croak 'Invalid receiver' unless defined $rcv;
@{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0);
}
sub mbusy {
my ($rcv) = @_;
+ croak 'Invalid receiver' unless defined $rcv;
return $rcv->{state} > 0;
}
=head2 C<mlastsender>
- mlastmsg $rcv
+ mlastsender $rcv
Holds the PID of the last process that sent data to the receiver C<$rcv>, C<0> if that process was anonymous, or C<undef> if no message has arrived yet. It isn't cleared by L</mreset>.
sub mlastsender {
my ($rcv) = @_;
+ croak 'Invalid receiver' unless defined $rcv;
return $rcv->{sender};
}
sub mlastmsg {
my ($rcv) = @_;
+ croak 'Invalid receiver' unless defined $rcv;
return $rcv->{msg};
}
#!perl -T
+use strict;
+use warnings;
+
use Test::More tests => 1;
BEGIN {
#!perl -T
+use strict;
+use warnings;
+
use Test::More tests => 6;
require IPC::MorseSignals;
#!perl -T
+use strict;
+use warnings;
+
use Test::More tests => 2;
-use POSIX qw/SIGINT SIGTERM SIGKILL EXIT_SUCCESS EXIT_FAILURE WIFEXITED WEXITSTATUS/;
+use POSIX qw/SIGUSR1 SIGUSR2/;
my ($a, $b) = (0, 0);
#!perl -T
-use Test::More tests => 2;
-
-use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
-
-use IPC::MorseSignals qw/msend mrecv mreset/;
+use strict;
+use warnings;
-my $lives = 5;
-
-sub spawn {
- --$lives;
- die 'forked too many times' if $lives < 0;
- pipe my $rdr, my $wtr or die "pipe() failed: $!";
- my $pid = fork;
- if (!defined $pid) {
- die "fork() failed: $!";
- } elsif ($pid == 0) {
- close $rdr or die "close() failed: $!";
- my $block = 0;
- my $s = mrecv local %SIG, cb => sub {
- if ($block) {
- $block = 0;
- } else {
- select $wtr; $| = 1;
- print $wtr $_[0], ':', $_[1], "\n";
- select $wtr; $| = 1;
- }
- };
- $SIG{HUP} = sub { mreset $s };
- $SIG{__WARN__} = sub { $block = 1 };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- close $wtr or die "close() failed: $!";
- return ($pid, $rdr);
-}
-
-sub slaughter {
- my ($pid) = @_;
- kill SIGINT => $pid;
- kill SIGTERM => $pid;
- kill SIGKILL => $pid;
- waitpid $pid, 0;
-}
+use Test::More tests => 2;
-my ($pid, $rdr) = spawn;
+use lib 't/lib';
+use IPCMTest qw/try init cleanup/;
-sub trysend {
- my ($sign, $desc) = @_;
- my $speed = 2 ** 16;
- my $ok = 0;
- while (!$ok && (($speed /= 2) >= 1)) {
- my $r = '';
- eval {
- local $SIG{ALRM} = sub { die 'timeout' };
- local $SIG{__WARN__} = sub { die 'do not want warnings' };
- my $a = (int(300 / $speed) || 1);
- $a = 10 if $a > 10;
- alarm $a;
- kill SIGHUP => $pid;
- msend 'x' => $pid, speed => $speed, sign => $sign;
- $r = <$rdr>;
- };
- kill SIGHUP => $pid if $@;
- alarm 0;
- if (!defined $r) { # Something bad happened, respawn
- close $rdr or die "close() failed: $!";
- slaughter $pid;
- ($pid, $rdr) = spawn;
- $speed *= 2; # Retry this speed
- } else {
- chomp $r;
- my ($p, $m) = split /:/, $r;
- $ok = ($m eq 'x') && ($p == ($sign ? $$ : 0)) if defined $m and defined $p;
- }
- }
- ok($ok, $desc);
-}
+init;
-trysend 0, 'anonymous';
-trysend 1, 'signed';
+ok(try('x', 0), 'anonymous');
+ok(try('x', 1), 'signed');
-slaughter $pid;
+cleanup;
#!perl -T
-use Test::More tests => 4 * 3;
+use strict;
+use warnings;
-use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+use Test::More tests => 4;
-use IPC::MorseSignals qw/msend mrecv mreset/;
+use lib 't/lib';
+use IPCMTest qw/try init cleanup/;
-my $lives = 5;
+init;
-sub spawn {
- --$lives;
- die 'forked too many times' if $lives < 0;
- pipe my $rdr, my $wtr or die "pipe() failed: $!";
- my $pid = fork;
- if (!defined $pid) {
- die "fork() failed: $!";
- } elsif ($pid == 0) {
- close $rdr or die "close() failed: $!";
- my $block = 0;
- my $s = mrecv local %SIG, cb => sub {
- if ($block) {
- $block = 0;
- } else {
- select $wtr; $| = 1;
- print $wtr $_[1], "\n";
- select $wtr; $| = 1;
- }
- };
- $SIG{HUP} = sub { mreset $s };
- $SIG{__WARN__} = sub { $block = 1 };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- close $wtr or die "close() failed: $!";
- return ($pid, $rdr);
-}
+ok(try('hello'), 'ascii');
+ok(try("\0" x 5), 'few bits');
+ok(try("\x{FF}" x 5), 'lots of bits');
+ok(try("a\0b"), 'null character');
-sub slaughter {
- my ($pid) = @_;
- kill SIGINT => $pid;
- kill SIGTERM => $pid;
- kill SIGKILL => $pid;
- waitpid $pid, 0;
-}
-
-my ($pid, $rdr) = spawn;
-
-sub trysend {
- my ($msg, $desc) = @_;
- my $speed = 2 ** 16;
- my $ok = 0;
- while (!$ok && (($speed /= 2) >= 1)) {
- my $r = '';
- eval {
- local $SIG{ALRM} = sub { die 'timeout' };
- local $SIG{__WARN__} = sub { die 'do not want warnings' };
- my $a = (int(100 * (3 * length $msg) / $speed) || 1);
- $a = 10 if $a > 10;
- alarm $a;
- kill SIGHUP => $pid;
- msend $msg => $pid, speed => $speed, sign => 0;
- $r = <$rdr>;
- };
- kill SIGHUP => $pid if $@;
- alarm 0;
- if (!defined $r) { # Something bad happened, respawn
- close $rdr or die "close() failed: $!";
- slaughter $pid;
- ($pid, $rdr) = spawn;
- $speed *= 2; # Retry this speed
- } else {
- chomp $r;
- if ($r eq $msg) {
- $ok = 1;
- } else {
- kill SIGHUP => $pid;
- }
- }
- }
- ok($ok, $desc);
-}
-
-for (1 .. 3) {
- trysend 'hello', 'ascii';
- trysend "\0" x 10, 'few bits';
- trysend "\x{FF}" x 10, 'lots of bits';
- trysend "a\0b", 'null character';
-}
-
-slaughter $pid;
+cleanup;
#!perl -T
-use Test::More tests => 7 * 3;
+use strict;
+use warnings;
-use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
-
-use IPC::MorseSignals qw/msend mrecv mreset/;
+use Test::More tests => 7;
use utf8;
-my $lives = 5;
-
-sub spawn {
- --$lives;
- die 'forked too many times' if $lives < 0;
- pipe my $rdr, my $wtr or die "pipe() failed: $!";
- my $pid = fork;
- if (!defined $pid) {
- die "fork() failed: $!";
- } elsif ($pid == 0) {
- close $rdr or die "close() failed: $!";
- binmode $wtr, ':utf8';
- my $block = 0;
- my $s = mrecv local %SIG, cb => sub {
- if ($block) {
- $block = 0;
- } else {
- select $wtr; $| = 1;
- print $wtr $_[1], "\n";
- select $wtr; $| = 1;
- }
- };
- $SIG{HUP} = sub { mreset $s };
- $SIG{__WARN__} = sub { $block = 1 };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- close $wtr or die "close() failed: $!";
- binmode $rdr, ':utf8';
- return ($pid, $rdr);
-}
-
-sub slaughter {
- my ($pid) = @_;
- kill SIGINT => $pid;
- kill SIGTERM => $pid;
- kill SIGKILL => $pid;
- waitpid $pid, 0;
-}
-
-my ($pid, $rdr) = spawn;
+use lib 't/lib';
+use IPCMTest qw/try init cleanup/;
-sub trysend8 {
- my ($msg, $desc) = @_;
- my $speed = 2 ** 16;
- my $ok = 0;
- $desc .= ' (unicode)';
- while (!$ok && (($speed /= 2) >= 1)) {
- my $r = '';
- eval {
- local $SIG{ALRM} = sub { die 'timeout' };
- local $SIG{__WARN__} = sub { die 'do not want warnings' };
- my $a = (int(100 * (3 * length $msg) / $speed) || 1);
- $a = 10 if $a > 10;
- alarm $a;
- kill SIGHUP => $pid;
- msend $msg => $pid, speed => $speed, utf8 => 1, sign => 0;
- $r = <$rdr>;
- };
- kill SIGHUP => $pid if $@;
- alarm 0;
- if (!defined $r) { # Something bad happened, respawn
- close $rdr or die "close() failed: $!";
- slaughter $pid;
- ($pid, $rdr) = spawn;
- $speed *= 2; # Retry this speed
- } else {
- chomp $r;
- if ($r eq $msg) {
- $ok = 1;
- } else {
- kill SIGHUP => $pid;
- }
- }
- }
- ok($ok, $desc);
-}
+init 1;
-for (1 .. 3) {
- trysend8 'hello', 'ascii';
- trysend8 "\0" x 10, 'few bits';
- trysend8 "\x{FF}" x 10, 'lots of bits';
- trysend8 "a\0b", 'null character';
- trysend8 'éàùçà', 'extended';
- trysend8 '€€€', 'unicode';
- trysend8 'a€bécàd€e', 'mixed';
-}
+ok(try('hello'), 'ascii');
+ok(try("\0" x 5), 'few bits');
+ok(try("\x{FF}" x 5), 'lots of bits');
+ok(try("a\0b"), 'null character');
+ok(try('éàùçà'), 'extended');
+ok(try('€€€'), 'unicode');
+ok(try('à€béd'), 'mixed');
-slaughter $pid;
+cleanup;
#!perl -T
-use Test::More tests => 10;
+use strict;
+use warnings;
-use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_SUCCESS EXIT_FAILURE/;
+use Test::More tests => 3;
-use IPC::MorseSignals qw/msend mrecv mreset/;
-
-my $lives = 10;
-
-sub spawn {
- --$lives;
- die 'forked too many times' if $lives < 0;
- pipe my $rdr, my $wtr or die "pipe() failed: $!";
- my $pid = fork;
- if (!defined $pid) {
- die "fork() failed: $!";
- } elsif ($pid == 0) {
- close $rdr or die "close() failed: $!";
- my $block = 0;
- my $s = mrecv local %SIG, cb => sub {
- if ($block) {
- $block = 0;
- } else {
- select $wtr; $| = 1;
- print $wtr $_[1], "\n";
- select $wtr; $| = 1;
- }
- };
- $SIG{HUP} = sub { mreset $s };
- $SIG{__WARN__} = sub { $block = 1; };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- close $wtr or die "close() failed: $!";
- return ($pid, $rdr);
-}
-
-sub slaughter {
- my ($pid) = @_;
- kill SIGINT => $pid;
- kill SIGTERM => $pid;
- kill SIGKILL => $pid;
- waitpid $pid, 0;
-}
+use lib 't/lib';
+use IPCMTest qw/speed init cleanup/;
+my $diag = sub { diag @_ };
my @res;
-my ($pid, $rdr) = spawn;
-
-sub tryspeed {
- my ($l, $n) = @_;
- my $speed = 2 ** 16;
- my $ok = 0;
- my @alpha = ('a' .. 'z');
- my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
- my $desc_base = "$l bytes sent $n times";
- while (($ok < $n) && (($speed /= 2) >= 1)) {
- my $desc = "$desc_base at $speed bits/s";
- diag("try $desc...");
-TRY:
- for (1 .. $n) {
- my $r = '';
- eval {
- local $SIG{ALRM} = sub { die 'timeout' };
- local $SIG{__WARN__} = sub { die 'do not want warnings' };
- my $a = (int(100 * (3 * $l) / $speed) || 1);
- $a = 10 if $a > 10;
- alarm $a;
- kill SIGHUP => $pid;
- msend $msg => $pid, speed => $speed;
- $r = <$rdr>;
- };
- kill SIGHUP => $pid if $@;
- alarm 0;
- if (!defined $r) { # Something bad happened, respawn
- close $rdr or die "close() failed: $!";
- slaughter $pid;
- ($pid, $rdr) = spawn;
- redo TRY; # Retry this send
- } else {
- chomp $r;
- if ($r eq $msg) {
- ++$ok;
- } else {
- kill SIGHUP => $pid;
- last TRY;
- }
- }
- }
- }
- ok($ok >= $n, $desc_base);
- push @res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
-}
+init;
-tryspeed 4, 1;
-tryspeed 4, 4;
-tryspeed 4, 16;
-tryspeed 4, 64;
-tryspeed 16, 1;
-tryspeed 16, 4;
-tryspeed 16, 16;
-tryspeed 64, 1;
-tryspeed 64, 4;
-tryspeed 256, 1;
+ok(speed(4, 1, $diag, \@res));
+ok(speed(4, 4, $diag, \@res));
+ok(speed(16, 1, $diag, \@res));
-slaughter $pid;
+cleanup;
diag '=== Summary ===';
diag $_ for sort {
--- /dev/null
+package IPCMTest;
+
+use strict;
+use warnings;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use IPC::MorseSignals qw/msend mrecv mreset/;
+
+use base qw/Exporter/;
+
+our @EXPORT_OK = qw/try speed init cleanup/;
+
+our $lives = 10;
+
+my ($utf8, $pid, $rdr);
+
+sub spawn {
+ --$lives;
+ die 'forked too many times' if $lives < 0;
+ pipe $rdr, my $wtr or die "pipe() failed: $!";
+ $pid = fork;
+ if (!defined $pid) {
+ die "fork() failed: $!";
+ } elsif ($pid == 0) {
+ close $rdr or die "close() failed: $!";
+ binmode $wtr, ':utf8' if $utf8;
+ my $block = 0;
+ my $rcv = mrecv local %SIG, cb => sub {
+ if ($block) {
+ $block = 0;
+ } else {
+ select $wtr; $| = 1;
+ print $wtr $_[0], ':', $_[1], "\n";
+ select $wtr; $| = 1;
+ }
+ };
+ $SIG{HUP} = sub { mreset $rcv };
+ $SIG{__WARN__} = sub { $block = 1 };
+ 1 while 1;
+ exit EXIT_FAILURE;
+ }
+ close $wtr or die "close() failed: $!";
+ binmode $rdr, ':utf8' if $utf8;
+}
+
+sub slaughter {
+ kill SIGINT => $pid;
+ kill SIGTERM => $pid;
+ kill SIGKILL => $pid;
+ waitpid $pid, 0;
+}
+
+sub init {
+ $utf8 = $_[0] || 0;
+ spawn;
+}
+
+sub cleanup { slaughter }
+
+sub try {
+ my ($msg, $sign) = @_;
+ $sign ||= 0;
+ my $speed = 2 ** 16;
+ my $ok = 0;
+ my @ret;
+ while (!$ok && (($speed /= 2) >= 1)) {
+ my $r = '';
+ eval {
+ local $SIG{ALRM} = sub { die 'timeout' };
+ local $SIG{__WARN__} = sub { die 'do not want warnings' };
+ my $a = (int(100 * (3 * length $msg) / $speed) || 1);
+ $a = 10 if $a > 10;
+ alarm $a;
+ kill SIGHUP => $pid;
+ msend $msg => $pid, speed => $speed, utf8 => $utf8, sign => $sign;
+ $r = <$rdr>;
+ };
+ kill SIGHUP => $pid if $@;
+ alarm 0;
+ if (!defined $r) { # Something bad happened, respawn
+ close $rdr or die "close() failed: $!";
+ slaughter;
+ spawn;
+ $speed *= 2; # Retry this speed
+ } else {
+ chomp $r;
+ if ($r eq ((($sign) ? $$ : 0) . ':' . $msg)) {
+ $ok = 1;
+ } else {
+ kill SIGHUP => $pid;
+ }
+ }
+ }
+ return ($ok) ? $speed : 0;
+}
+
+sub speed {
+ my ($l, $n, $diag, $res) = @_;
+ my $speed = 2 ** 16;
+ my $ok = 0;
+ my @alpha = ('a' .. 'z');
+ my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
+ my $desc_base = "$l bytes sent $n times";
+ while (($ok < $n) && (($speed /= 2) >= 1)) {
+ my $desc = "$desc_base at $speed bits/s";
+ $diag->("try $desc...");
+TRY:
+ for (1 .. $n) {
+ my $r = '';
+ eval {
+ local $SIG{ALRM} = sub { die 'timeout' };
+ local $SIG{__WARN__} = sub { die 'do not want warnings' };
+ my $a = (int(100 * (3 * $l) / $speed) || 1);
+ $a = 10 if $a > 10;
+ alarm $a;
+ kill SIGHUP => $pid;
+ msend $msg => $pid, speed => $speed, utf8 => $utf8, sign => 0;
+ $r = <$rdr>;
+ };
+ kill SIGHUP => $pid if $@;
+ alarm 0;
+ if (!defined $r) { # Something bad happened, respawn
+ close $rdr or die "close() failed: $!";
+ slaughter;
+ spawn;
+ redo TRY; # Retry this send
+ } else {
+ chomp $r;
+ if ($r eq '0:' . $msg) {
+ ++$ok;
+ } else {
+ kill SIGHUP => $pid;
+ last TRY;
+ }
+ }
+ }
+ }
+ push @$res, $desc_base . (($speed) ? ' at ' . $speed . ' bits/s' : ' failed');
+ return ($ok == $n);
+}
+
+1;
projects / perl / modules / IPC-MorseSignals.git / commitdiff