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.
--- #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
PL_FILES => {},
PREREQ_PM => {
'Carp' => 0,
+ 'Encode' => 0,
'Exporter' => 0,
'POSIX' => 0,
'Test::More' => 0,
IPC::MorseSignals - Communicate between processes with Morse signals.
VERSION
- Version 0.07
+ Version 0.08
SYNOPSIS
use IPC::MorseSignals qw/msend mrecv/;
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 ]
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
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.
use utf8;
use Carp qw/croak/;
+use Encode;
use POSIX qw/SIGUSR1 SIGUSR2/;
use Time::HiRes qw/usleep/;
=head1 VERSION
-Version 0.07
+Version 0.08
=cut
-our $VERSION = '0.07';
+our $VERSION = '0.08';
=head1 SYNOPSIS
=head2 C<msend>
- 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<utf8> flag is set (default is unset), the string will first be encoded in UTF-8. The C<utf8> bit of the packet message is turned on, so that the receiver is aware of it. If the C<sign> flag is unset (default is set), the PID of the sender won't be shipped with the packet.
+If the C<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 C<utf8> bit of the packet message is turned on, so that the receiver can encode them appropriately.
=cut
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 == $_) {
$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};
}
=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
=head1 DEPENDENCIES
-L<Carp> (standard since perl 5), L<POSIX> (idem), L<Time::HiRes> (since perl 5.7.3) and L<utf8> (since perl 5.6) are required.
+L<Carp> (standard since perl 5), L<POSIX> (idem), L<utf8> (since perl 5.6), L<Encode> (since perl 5.7.3) and L<Time::HiRes> (idem) are required.
=head1 SEE ALSO
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;
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;
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;
my $diag = sub { diag @_ };
my @res;
-init;
+init 12;
ok(speed(4, 1, $diag, \@res));
ok(speed(4, 4, $diag, \@res));
use strict;
use warnings;
+
use Test::More tests => 3;
sub not_in_file_ok {
#!perl
+use strict;
+use warnings;
+
use Test::More;
eval { require Test::Kwalitee; Test::Kwalitee->import() };
use strict;
use warnings;
+use Encode;
use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
use IPC::MorseSignals qw/msend mrecv mreset/;
our @EXPORT_OK = qw/try speed init cleanup/;
-our $lives = 10;
-
-my ($utf8, $pid, $rdr);
+my ($lives, $pid, $rdr);
sub spawn {
--$lives;
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 {
}
sub init {
- $utf8 = $_[0] || 0;
+ ($lives) = @_;
+ $lives ||= 10;
spawn;
}
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)) {
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:
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) {
#!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();
#!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();
projects / perl / modules / IPC-MorseSignals.git / commitdiff