From: Vincent Pit Date: Sun, 29 Jun 2008 16:35:36 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.07.tar.gz X-Git-Tag: v0.07^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=commitdiff_plain;h=8a4a3ba553f81cfdb679c19363f514efb04f29c1 Importing IPC-MorseSignals-0.07.tar.gz --- diff --git a/Changes b/Changes index 096dd93..dea8115 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ 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 diff --git a/MANIFEST b/MANIFEST index f1f7a2b..44f3e0e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -17,3 +17,4 @@ t/boilerplate.t t/kwalitee.t t/pod-coverage.t t/pod.t +t/lib/IPCMTest.pm diff --git a/META.yml b/META.yml index 9c2a7af..348e292 100644 --- a/META.yml +++ b/META.yml @@ -1,12 +1,13 @@ --- #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 diff --git a/Makefile.PL b/Makefile.PL index 4a1f945..2366dc9 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -29,6 +29,7 @@ WriteMakefile( PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, + 'Exporter' => 0, 'POSIX' => 0, 'Test::More' => 0, 'Time::HiRes' => 0, diff --git a/README b/README index 098eddf..4cc7af9 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME IPC::MorseSignals - Communicate between processes with Morse signals. VERSION - Version 0.06 + Version 0.07 SYNOPSIS use IPC::MorseSignals qw/msend mrecv/; @@ -49,7 +49,7 @@ FUNCTIONS 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. @@ -66,7 +66,7 @@ FUNCTIONS 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. diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm index 098dfba..e9ef591 100644 --- a/lib/IPC/MorseSignals.pm +++ b/lib/IPC/MorseSignals.pm @@ -17,11 +17,11 @@ IPC::MorseSignals - Communicate between processes with Morse signals. =head1 VERSION -Version 0.06 +Version 0.07 =cut -our $VERSION = '0.06'; +our $VERSION = '0.07'; =head1 SYNOPSIS @@ -114,7 +114,7 @@ sub msend { 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 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. @@ -193,6 +193,7 @@ Resets the state of the receiver C<$rcv>. Useful to abort transfers. sub mreset { my ($rcv) = @_; + croak 'Invalid receiver' unless defined $rcv; @{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0); } @@ -206,12 +207,13 @@ Returns true if the receiver C<$rcv> is currently busy with incoming data, or fa sub mbusy { my ($rcv) = @_; + croak 'Invalid receiver' unless defined $rcv; return $rcv->{state} > 0; } =head2 C - 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 if no message has arrived yet. It isn't cleared by L. @@ -219,6 +221,7 @@ Holds the PID of the last process that sent data to the receiver C<$rcv>, C<0> i sub mlastsender { my ($rcv) = @_; + croak 'Invalid receiver' unless defined $rcv; return $rcv->{sender}; } @@ -232,6 +235,7 @@ Holds the last message received by C<$rcv>, or C if no message has arrive sub mlastmsg { my ($rcv) = @_; + croak 'Invalid receiver' unless defined $rcv; return $rcv->{msg}; } diff --git a/t/00-load.t b/t/00-load.t index 0138a80..fbef782 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -1,5 +1,8 @@ #!perl -T +use strict; +use warnings; + use Test::More tests => 1; BEGIN { diff --git a/t/01-import.t b/t/01-import.t index 071e5e4..ab6dd3a 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -1,5 +1,8 @@ #!perl -T +use strict; +use warnings; + use Test::More tests => 6; require IPC::MorseSignals; diff --git a/t/02-sigusr.t b/t/02-sigusr.t index 112f5e6..bfe2dc2 100644 --- a/t/02-sigusr.t +++ b/t/02-sigusr.t @@ -1,8 +1,11 @@ #!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); diff --git a/t/10-proto.t b/t/10-proto.t index 307e17b..d05c7ef 100644 --- a/t/10-proto.t +++ b/t/10-proto.t @@ -1,84 +1,16 @@ #!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; diff --git a/t/11-ascii.t b/t/11-ascii.t index 53890cc..b5cc073 100644 --- a/t/11-ascii.t +++ b/t/11-ascii.t @@ -1,91 +1,18 @@ #!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; diff --git a/t/12-unicode.t b/t/12-unicode.t index 0d3af16..77ce70c 100644 --- a/t/12-unicode.t +++ b/t/12-unicode.t @@ -1,99 +1,23 @@ #!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; diff --git a/t/13-speed.t b/t/13-speed.t index f2409d1..ee5a80c 100644 --- a/t/13-speed.t +++ b/t/13-speed.t @@ -1,110 +1,23 @@ #!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 { diff --git a/t/lib/IPCMTest.pm b/t/lib/IPCMTest.pm new file mode 100644 index 0000000..33d006c --- /dev/null +++ b/t/lib/IPCMTest.pm @@ -0,0 +1,143 @@ +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;