From: Vincent Pit Date: Sun, 29 Jun 2008 16:35:38 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.09.tar.gz X-Git-Tag: v0.09^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=commitdiff_plain;h=accfcdfb12dc278650d05fed5f14d78291e66d97 Importing IPC-MorseSignals-0.09.tar.gz --- diff --git a/Changes b/Changes index f3f1135..b688350 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,14 @@ Revision history for IPC-MorseSignals +0.09 2008-02-03 18:25 UTC + + Tst : Fix a race in child creation : the parent could send the message + before the child was ready to receive it. + + Tst : Turn autoflush on onto the reader end of the pipe. + + Tst : Renamed IPCMTest to IPC::MorseSignals::TestSuite + + Tst : Prefix author tests by 9*-. + + Tst : New optional author test : 95-portability-files.t, that uses + Test::Portability::Files when it's present. + 0.08 2007-09-05 09:40 UTC + Chg : The sender detects now automatically if the message is encoded in UTF-8, thanks to Encode::is_utf8. You no longer need to pass diff --git a/MANIFEST b/MANIFEST index 44f3e0e..531a6be 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,8 +13,9 @@ t/10-proto.t t/11-ascii.t t/12-unicode.t t/13-speed.t -t/boilerplate.t -t/kwalitee.t -t/pod-coverage.t -t/pod.t -t/lib/IPCMTest.pm +t/90-boilerplate.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t +t/lib/IPC/MorseSignals/TestSuite.pm diff --git a/META.yml b/META.yml index f5ae110..a30e059 100644 --- a/META.yml +++ b/META.yml @@ -1,9 +1,11 @@ --- #YAML:1.0 name: IPC-MorseSignals -version: 0.08 +version: 0.09 abstract: Communicate between processes with Morse signals. license: perl -generated_by: ExtUtils::MakeMaker version 6.36 +author: + - Vincent Pit +generated_by: ExtUtils::MakeMaker version 6.42 distribution_type: module requires: Carp: 0 @@ -14,7 +16,5 @@ requires: Time::HiRes: 0 utf8: 0 meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.2.html - version: 1.2 -author: - - Vincent Pit + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 diff --git a/README b/README index a2fadc0..c445bc8 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME IPC::MorseSignals - Communicate between processes with Morse signals. VERSION - Version 0.08 + Version 0.09 SYNOPSIS use IPC::MorseSignals qw/msend mrecv/; diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm index d6bd905..50cb85e 100644 --- a/lib/IPC/MorseSignals.pm +++ b/lib/IPC/MorseSignals.pm @@ -18,11 +18,11 @@ IPC::MorseSignals - Communicate between processes with Morse signals. =head1 VERSION -Version 0.08 +Version 0.09 =cut -our $VERSION = '0.08'; +our $VERSION = '0.09'; =head1 SYNOPSIS diff --git a/samples/bench.pl b/samples/bench.pl index 317f794..8083bf8 100755 --- a/samples/bench.pl +++ b/samples/bench.pl @@ -19,26 +19,39 @@ sub spawn { if (!defined $pid) { die "fork() failed: $!"; } elsif ($pid == 0) { + local %SIG; close $rdr or die "close() failed: $!"; - my $s = mrecv local %SIG, cb => sub { - select $wtr; $| = 1; - print $wtr $_[1], "\n"; - select $wtr; $| = 1; - }; - $SIG{'HUP'} = sub { mreset $s }; + select $wtr; + $| = 1; + my $rcv = mrecv %SIG, cb => sub { print $wtr $_[1], "\n" }; + my $ppid = getppid; + $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid }; + alarm 1; + $SIG{HUP} = sub { alarm 0; mreset $rcv }; 1 while 1; exit EXIT_FAILURE; } + my $ready = 0; + local $SIG{HUP} = sub { $ready = 1 }; + sleep 1 until $ready; close $wtr or die "close() failed: $!"; + my $oldfh = select $rdr; + $| = 1; + select $oldfh; return ($pid, $rdr); } sub slaughter { - my ($pid) = @_; - kill SIGINT => $pid; - kill SIGTERM => $pid; - kill SIGKILL => $pid; - waitpid $pid, 0; + my ($pid, $rdr) = @_; + if (defined $rdr) { + close $rdr or die "close() failed: $!"; + } + if (defined $pid) { + kill SIGINT => $pid; + kill SIGTERM => $pid; + kill SIGKILL => $pid; + waitpid $pid, 0; + } } my @res; @@ -69,8 +82,7 @@ TRY: alarm 0; if (!defined $r) { # Something bad happened, respawn print STDERR "oops\n"; - close $rdr or die "close() failed: $!"; - slaughter $pid; + slaughter $pid, $rdr; ($pid, $rdr) = spawn; redo TRY; # Retry this send } else { diff --git a/t/10-proto.t b/t/10-proto.t index 5c25980..5cd76ba 100644 --- a/t/10-proto.t +++ b/t/10-proto.t @@ -6,7 +6,7 @@ use warnings; use Test::More tests => 2; use lib 't/lib'; -use IPCMTest qw/try init cleanup/; +use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; diff --git a/t/11-ascii.t b/t/11-ascii.t index a9b6d69..033c036 100644 --- a/t/11-ascii.t +++ b/t/11-ascii.t @@ -6,7 +6,7 @@ use warnings; use Test::More tests => 4; use lib 't/lib'; -use IPCMTest qw/try init cleanup/; +use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; diff --git a/t/12-unicode.t b/t/12-unicode.t index e0cfab3..7102311 100644 --- a/t/12-unicode.t +++ b/t/12-unicode.t @@ -8,7 +8,7 @@ use Test::More tests => 7; use utf8; use lib 't/lib'; -use IPCMTest qw/try init cleanup/; +use IPC::MorseSignals::TestSuite qw/try init cleanup/; sub test { my ($desc, @args) = @_; diff --git a/t/13-speed.t b/t/13-speed.t index 6398de0..02de5b1 100644 --- a/t/13-speed.t +++ b/t/13-speed.t @@ -6,7 +6,7 @@ use warnings; use Test::More tests => 3; use lib 't/lib'; -use IPCMTest qw/speed init cleanup/; +use IPC::MorseSignals::TestSuite qw/speed init cleanup/; my $diag = sub { diag @_ }; my @res; diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..9918dc9 --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,49 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 3; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open my $fh, "<", $filename + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, +); + +not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) +); + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +module_boilerplate_ok('lib/IPC/MorseSignals.pm'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..f1e1d3e --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..5cc37aa --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok(); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm new file mode 100644 index 0000000..ab82470 --- /dev/null +++ b/t/lib/IPC/MorseSignals/TestSuite.pm @@ -0,0 +1,155 @@ +package IPC::MorseSignals::TestSuite; + +use strict; +use warnings; + +use Encode; +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/; + +my ($lives, $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) { + local %SIG; + close $rdr or die "close() failed: $!"; + select $wtr; + $| = 1; + $SIG{__WARN__} = sub { print $wtr "!warn\n"; }; + my $rcv = mrecv %SIG, cb => sub { + my $is_utf8 = Encode::is_utf8($_[1]); + binmode $wtr, ':utf8' if $is_utf8; + print $wtr $_[0], ':', $_[1], "\n"; + binmode $wtr, ':crlf' if $is_utf8; + }; + my $ppid = getppid; + $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid }; + alarm 1; + $SIG{HUP} = sub { alarm 0; mreset $rcv }; # We can reset the alarm here. + 1 while 1; + exit EXIT_FAILURE; + } + my $ready = 0; + local $SIG{HUP} = sub { $ready = 1 }; + sleep 1 until $ready; + close $wtr or die "close() failed: $!"; + my $oldfh = select $rdr; + $| = 1; + select $oldfh; +} + +sub slaughter { + if (defined $rdr) { + close $rdr or die "close() falied: $!"; + undef $rdr; + } + if (defined $pid) { + kill SIGINT => $pid; + kill SIGTERM => $pid; + kill SIGKILL => $pid; + waitpid $pid, 0; + undef $pid; + } +} + +sub init { + ($lives) = @_; + $lives ||= 10; + undef $pid; + undef $rdr; + spawn; +} + +sub cleanup { slaughter } + +sub try { + my ($msg, $sign) = @_; + $sign ||= 0; + my $speed = 2 ** 16; + my $ok = 0; + my @ret; + binmode $rdr, ((Encode::is_utf8 $msg) ? ':utf8' : ':crlf'); + while (!$ok && (($speed /= 2) >= 1)) { + 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 * length $msg) / $speed) || 1); + $a = 10 if $a > 10; + alarm $a; + kill SIGHUP => $pid; + msend $msg => $pid, speed => $speed, sign => $sign; + $r = <$rdr>; + alarm 0; + }; + if (!defined $r) { # Something bad happened, respawn + slaughter; + spawn; + } 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 time" . ('s' x ($n != 1)); + while (($ok < $n) && (($speed /= 2) >= 1)) { + $ok = 0; + 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 { alarm 0; 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, sign => 0; + $r = <$rdr>; + alarm 0; + }; + if (!defined $r) { # Something bad happened, respawn + slaughter; + spawn; + last TRY; + } 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;