From: Vincent Pit Date: Sun, 29 Jun 2008 16:35:37 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.08.tar.gz X-Git-Tag: v0.08^0 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FIPC-MorseSignals.git;a=commitdiff_plain;h=f92bbcf77fb757c6655f4611c900c49ed178f27e Importing IPC-MorseSignals-0.08.tar.gz --- diff --git a/Changes b/Changes index dea8115..f3f1135 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,13 @@ Revision history for IPC-MorseSignals +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 + the utf8 option to msend. The Encode module is a prerequisite. + + Chg : Tests that used to die now report correct failure. + + Fix : Tests are now strict. + + Fix : Miscount in t/13-speed.t + 0.07 2007-08-28 11:30 UTC + Chg : Common test code was factored into a module. + Chg : Tests were lightened again. diff --git a/META.yml b/META.yml index 348e292..f5ae110 100644 --- a/META.yml +++ b/META.yml @@ -1,12 +1,13 @@ --- #YAML:1.0 name: IPC-MorseSignals -version: 0.07 +version: 0.08 abstract: Communicate between processes with Morse signals. license: perl generated_by: ExtUtils::MakeMaker version 6.36 distribution_type: module requires: Carp: 0 + Encode: 0 Exporter: 0 POSIX: 0 Test::More: 0 diff --git a/Makefile.PL b/Makefile.PL index 2366dc9..2a416bd 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -29,6 +29,7 @@ WriteMakefile( PL_FILES => {}, PREREQ_PM => { 'Carp' => 0, + 'Encode' => 0, 'Exporter' => 0, 'POSIX' => 0, 'Test::More' => 0, diff --git a/README b/README index 4cc7af9..a2fadc0 100644 --- a/README +++ b/README @@ -2,7 +2,7 @@ NAME IPC::MorseSignals - Communicate between processes with Morse signals. VERSION - Version 0.07 + Version 0.08 SYNOPSIS use IPC::MorseSignals qw/msend mrecv/; @@ -29,16 +29,15 @@ DESCRIPTION FUNCTIONS "msend" - msend $msg, $pid [, speed => $speed, utf8 => $utf8, sign => $sign ] + msend $msg, $pid [, speed => $speed, sign => $sign ] Sends the string $msg to the process $pid (or to all the processes @$pid if $pid is an array ref) at $speed bits per second. Default speed is 512, don't set it too low or the target will miss bits and the whole - message will be crippled. If the "utf8" flag is set (default is unset), - the string will first be encoded in UTF-8. The "utf8" bit of the packet - message is turned on, so that the receiver is aware of it. If the "sign" - flag is unset (default is set), the PID of the sender won't be shipped - with the packet. + message will be crippled. If the "sign" flag is unset (default is set), + the PID of the sender won't be shipped with the packet. UTF-8 encoded + strings are automatically detected. The "utf8" bit of the packet message + is turned on, so that the receiver can encode them appropriately. "mrecv" mrecv %SIG [, cb => $callback ] @@ -95,8 +94,8 @@ PROTOCOL m) and 1 (n) in the concatenation of the header and the data. A signature is then chosen : - - If m > n, we take n+1 times 1 follewed by one 0 ; - - Otherwise, we take m+1 times 0 follewed by one 1. + - If m > n, we take n+1 times 1 followed by one 0 ; + - Otherwise, we take m+1 times 0 followed by one 1. The signal is then formed by concatenating the signature, the header, the data bits and the reversed signature (i.e. the bits of the signature @@ -117,8 +116,8 @@ CAVEATS transfer data to a sleeping process. DEPENDENCIES - Carp (standard since perl 5), POSIX (idem), Time::HiRes (since perl - 5.7.3) and utf8 (since perl 5.6) are required. + Carp (standard since perl 5), POSIX (idem), utf8 (since perl 5.6), + Encode (since perl 5.7.3) and Time::HiRes (idem) are required. SEE ALSO perlipc for information about signals in perl. diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm index e9ef591..d6bd905 100644 --- a/lib/IPC/MorseSignals.pm +++ b/lib/IPC/MorseSignals.pm @@ -6,6 +6,7 @@ use warnings; use utf8; use Carp qw/croak/; +use Encode; use POSIX qw/SIGUSR1 SIGUSR2/; use Time::HiRes qw/usleep/; @@ -17,11 +18,11 @@ IPC::MorseSignals - Communicate between processes with Morse signals. =head1 VERSION -Version 0.07 +Version 0.08 =cut -our $VERSION = '0.07'; +our $VERSION = '0.08'; =head1 SYNOPSIS @@ -50,10 +51,11 @@ But, seriously, use something else for your IPC. :) =head2 C - msend $msg, $pid [, speed => $speed, utf8 => $utf8, sign => $sign ] + msend $msg, $pid [, speed => $speed, sign => $sign ] Sends the string C<$msg> to the process C<$pid> (or to all the processes C<@$pid> if C<$pid> is an array ref) at C<$speed> bits per second. Default speed is 512, don't set it too low or the target will miss bits and the whole message will be crippled. -If the C flag is set (default is unset), the string will first be encoded in UTF-8. The C bit of the packet message is turned on, so that the receiver is aware of it. If the C flag is unset (default is set), the PID of the sender won't be shipped with the packet. +If the C flag is unset (default is set), the PID of the sender won't be shipped with the packet. +UTF-8 encoded strings are automatically detected. The C bit of the packet message is turned on, so that the receiver can encode them appropriately. =cut @@ -65,27 +67,24 @@ sub msend { croak 'Optional arguments must be passed as key => value pairs' if @o % 2; my %opts = @o; $opts{speed} ||= 512; - $opts{utf8} ||= 0; $opts{sign} = 1 unless defined $opts{sign}; + $opts{utf8} = Encode::is_utf8 $msg; my $delay = int(1_000_000 / $opts{speed}); - my @head = ( + # Form the header + my @bits = ( ($opts{utf8} ? 1 : 0), ($opts{sign} ? 1 : 0), ); if ($opts{sign}) { my $n = 2 ** PID_BITS; - push @head, ($$ & $n) ? 1 : 0 while ($n /= 2) >= 1; + push @bits, ($$ & $n) ? 1 : 0 while ($n /= 2) >= 1; } my $tpl = 'B*'; - if ($opts{utf8}) { - utf8::encode $msg; - $tpl = 'U0' . $tpl; - } - my @bits = split //, unpack $tpl, $msg; + $tpl = 'U0' . $tpl if $opts{utf8}; + push @bits, split //, unpack $tpl, $msg; - unshift @bits, @head; my ($c, $n, @l) = (2, 0, 0, 0, 0); for (@bits) { if ($c == $_) { @@ -141,6 +140,7 @@ sub mrecv (\%@) { $tpl = 'U0' . $tpl if $s->{utf8}; $s->{msg} = pack $tpl, $s->{bits}; mreset $s; +# Encode::_utf8_off $s->{msg} if !$s->{utf8}; # Workaround a bug in 5.8.x $s->{cb}->(@{$s}{qw/sender msg/}) if $s->{cb}; } @@ -262,9 +262,9 @@ The emitter computes then the longuest sequence of successives 0 (say, m) and 1 =over 4 -=item - If m > n, we take n+1 times 1 follewed by one 0 ; +=item - If m > n, we take n+1 times 1 followed by one 0 ; -=item - Otherwise, we take m+1 times 0 follewed by one 1. +=item - Otherwise, we take m+1 times 0 followed by one 1. =back @@ -283,7 +283,7 @@ C seem to interrupt sleep, so it's not a good idea to transfer data =head1 DEPENDENCIES -L (standard since perl 5), L (idem), L (since perl 5.7.3) and L (since perl 5.6) are required. +L (standard since perl 5), L (idem), L (since perl 5.6), L (since perl 5.7.3) and L (idem) are required. =head1 SEE ALSO diff --git a/t/10-proto.t b/t/10-proto.t index d05c7ef..5c25980 100644 --- a/t/10-proto.t +++ b/t/10-proto.t @@ -8,9 +8,15 @@ use Test::More tests => 2; use lib 't/lib'; use IPCMTest qw/try init cleanup/; -init; +sub test { + my ($desc, @args) = @_; + eval { ok(try(@args), $desc) }; + fail($desc . " (died : $@)") if $@; +} -ok(try('x', 0), 'anonymous'); -ok(try('x', 1), 'signed'); +init 6; + +test 'anonymous' => 'x', 0; +test 'signed' => 'x', 1; cleanup; diff --git a/t/11-ascii.t b/t/11-ascii.t index b5cc073..a9b6d69 100644 --- a/t/11-ascii.t +++ b/t/11-ascii.t @@ -8,11 +8,17 @@ use Test::More tests => 4; use lib 't/lib'; use IPCMTest qw/try init cleanup/; -init; +sub test { + my ($desc, @args) = @_; + eval { ok(try(@args), $desc) }; + fail($desc . " (died : $@)") if $@; +} -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'); +init 12; + +test 'ascii' => 'hello'; +test 'few bits' => "\0" x 5; +test 'lots of bits' => "\x{FF}" x 5; +test 'null character' => "a\0b"; cleanup; diff --git a/t/12-unicode.t b/t/12-unicode.t index 77ce70c..e0cfab3 100644 --- a/t/12-unicode.t +++ b/t/12-unicode.t @@ -10,14 +10,20 @@ use utf8; use lib 't/lib'; use IPCMTest qw/try init cleanup/; -init 1; - -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'); +sub test { + my ($desc, @args) = @_; + eval { ok(try(@args), $desc) }; + fail($desc . " (died : $@)") if $@; +} + +init 21; + +test 'ascii' => 'hello'; +test 'few bits' => "\0" x 5; +test 'lots of bits' => "\x{FF}" x 5; +test 'null character' => "a\0b"; +test 'extended' => 'éàùçà'; +test 'unicode' => '€€€'; +test 'mixed' => 'à€béd'; cleanup; diff --git a/t/13-speed.t b/t/13-speed.t index ee5a80c..6398de0 100644 --- a/t/13-speed.t +++ b/t/13-speed.t @@ -11,7 +11,7 @@ use IPCMTest qw/speed init cleanup/; my $diag = sub { diag @_ }; my @res; -init; +init 12; ok(speed(4, 1, $diag, \@res)); ok(speed(4, 4, $diag, \@res)); diff --git a/t/boilerplate.t b/t/boilerplate.t index 0e13af4..9918dc9 100644 --- a/t/boilerplate.t +++ b/t/boilerplate.t @@ -2,6 +2,7 @@ use strict; use warnings; + use Test::More tests => 3; sub not_in_file_ok { diff --git a/t/kwalitee.t b/t/kwalitee.t index 1e95c3d..7775e60 100644 --- a/t/kwalitee.t +++ b/t/kwalitee.t @@ -1,5 +1,8 @@ #!perl +use strict; +use warnings; + use Test::More; eval { require Test::Kwalitee; Test::Kwalitee->import() }; diff --git a/t/lib/IPCMTest.pm b/t/lib/IPCMTest.pm index 33d006c..6cd2f43 100644 --- a/t/lib/IPCMTest.pm +++ b/t/lib/IPCMTest.pm @@ -3,6 +3,7 @@ package IPCMTest; use strict; use warnings; +use Encode; use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/; use IPC::MorseSignals qw/msend mrecv mreset/; @@ -11,9 +12,7 @@ use base qw/Exporter/; our @EXPORT_OK = qw/try speed init cleanup/; -our $lives = 10; - -my ($utf8, $pid, $rdr); +my ($lives, $pid, $rdr); sub spawn { --$lives; @@ -23,25 +22,24 @@ sub spawn { if (!defined $pid) { die "fork() failed: $!"; } elsif ($pid == 0) { + local %SIG; 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; - } + my $rcv = mrecv %SIG, cb => sub { + binmode $wtr, ':utf8' if Encode::is_utf8 $_[1]; + select $wtr; $| = 1; + print $wtr $_[0], ':', $_[1], "\n"; + select $wtr; $| = 1; }; $SIG{HUP} = sub { mreset $rcv }; - $SIG{__WARN__} = sub { $block = 1 }; + $SIG{__WARN__} = sub { + select $wtr; $| = 1; + print $wtr "__WARN__\n"; + select $wtr; $| = 1; + }; 1 while 1; exit EXIT_FAILURE; } close $wtr or die "close() failed: $!"; - binmode $rdr, ':utf8' if $utf8; } sub slaughter { @@ -52,7 +50,8 @@ sub slaughter { } sub init { - $utf8 = $_[0] || 0; + ($lives) = @_; + $lives ||= 10; spawn; } @@ -64,25 +63,24 @@ sub try { 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 { die 'do not want warnings' }; + 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, utf8 => $utf8, sign => $sign; + msend $msg => $pid, speed => $speed, sign => $sign; $r = <$rdr>; + alarm 0; }; - 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)) { @@ -103,6 +101,7 @@ sub speed { my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l; my $desc_base = "$l bytes sent $n times"; while (($ok < $n) && (($speed /= 2) >= 1)) { + $ok = 0; my $desc = "$desc_base at $speed bits/s"; $diag->("try $desc..."); TRY: @@ -110,21 +109,20 @@ TRY: my $r = ''; eval { local $SIG{ALRM} = sub { die 'timeout' }; - local $SIG{__WARN__} = sub { die 'do not want warnings' }; + 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, utf8 => $utf8, sign => 0; + msend $msg => $pid, speed => $speed, sign => 0; $r = <$rdr>; + alarm 0; }; - 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 + last TRY; } else { chomp $r; if ($r eq '0:' . $msg) { diff --git a/t/pod-coverage.t b/t/pod-coverage.t index 703f91d..5cc37aa 100644 --- a/t/pod-coverage.t +++ b/t/pod-coverage.t @@ -1,6 +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/pod.t b/t/pod.t index 976d7cd..f1e1d3e 100644 --- a/t/pod.t +++ b/t/pod.t @@ -1,6 +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();