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
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
--- #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 <perl@profvince.com>
+generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
Carp: 0
Time::HiRes: 0
utf8: 0
meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.2.html
- version: 1.2
-author:
- - Vincent Pit <perl@profvince.com>
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
IPC::MorseSignals - Communicate between processes with Morse signals.
VERSION
- Version 0.08
+ Version 0.09
SYNOPSIS
use IPC::MorseSignals qw/msend mrecv/;
=head1 VERSION
-Version 0.08
+Version 0.09
=cut
-our $VERSION = '0.08';
+our $VERSION = '0.09';
=head1 SYNOPSIS
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;
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 {
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) = @_;
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) = @_;
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) = @_;
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;
--- /dev/null
+#!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');
--- /dev/null
+#!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();
--- /dev/null
+#!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();
--- /dev/null
+#!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();
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval { require Test::Kwalitee; Test::Kwalitee->import() };
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
--- /dev/null
+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;
projects / perl / modules / IPC-MorseSignals.git / commitdiff