Revision history for IPC-MorseSignals
+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
+ mask it).
+ + Add : New functions : mreset(), mlastmsg(), mlastsender().
+ + Chg : msend() accepts now the sign option, to specify is the sender
+ can put its PID into the message packet or not (default is yes).
+ + Chg : mrecv() now returns a hash reference that holds the receiver's
+ state. %SIG has to be passed as the first argument. The callback
+ is no longer mandatory and should be passed with the cb key. The
+ utf8 key was removed.
+ + Chg : The tests call fork() only one time.
+
0.05 2007-08-18 16:50 UTC
+ Add : m{send,recv} will croak() if any of their arguments is invalid.
+ Chg : The requirements to pass the speed test were lowered.
t/00-load.t
t/01-import.t
t/02-sigusr.t
-t/10-base.t
-t/11-unicode.t
-t/12-speed.t
+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
--- #YAML:1.0
name: IPC-MorseSignals
-version: 0.05
+version: 0.06
abstract: Communicate between processes with Morse signals.
license: perl
generated_by: ExtUtils::MakeMaker version 6.36
IPC::MorseSignals - Communicate between processes with Morse signals.
VERSION
- Version 0.05
+ Version 0.06
SYNOPSIS
use IPC::MorseSignals qw/msend mrecv/;
if (!defined $pid) {
die "fork() failed: $!";
} elsif ($pid == 0) {
- local @SIG{qw/USR1 USR2/} = mrecv sub {
- print STDERR "received $_[0]!\n";
+ my $s = mrecv local %SIG, cb => sub {
+ print STDERR "received $_[1] from $_[0]!\n";
exit
};
1 while 1;
FUNCTIONS
"msend"
- msend $msg, $pid [, speed => $speed, utf8 => $utf8 ]
+ msend $msg, $pid [, speed => $speed, utf8 => $utf8, 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. If the "utf8" flag
- is set, the string will first be encoded in UTF-8. In this case, you
- must turn it on for "mrecv" as well. Default speed is 512, don't set it
- too low or the target will miss bits and the whole message will be
- crippled. The "utf8" flag is turned off by default.
+ 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.
"mrecv"
- mrecv $callback [, utf => $utf8 ]
+ mrecv %SIG [, cb => $callback ]
- Takes as its first argument the callback triggered when a complete
- message is received, and returns two code references that should replace
- "USR1" and "USR2" signal handlers. Basically, you want to use it like
- this :
+ Takes as its first argument the %SIG hash and returns a hash reference
+ that represent the current state of the receiver. %SIG's fields 'USR1'
+ and 'USR2' will be replaced by the receiver's callbacks. "cb" specifies
+ the callback to trigger each time a complete message has arrived.
+ Basically, you want to use it like this :
- local @SIG{qw/USR1 USR2/} = mrecv sub { ... };
+ my $rv = mrecv local %SIG, cb => sub { ... };
- Turn on the utf8 flag if you know that the incoming strings are expected
- to be in UTF-8. This flag is turned off by default.
+ In the callback, $_[0] is the sender's PID (or 0 if the sender wanted to
+ stay anonymous) and $_[1] is the message received.
+
+ "mreset"
+ mreset $rcv
+
+ Resets the state of the receiver $rcv. Useful to abort transfers.
+
+ "mbusy"
+ mbusy $rcv
+
+ Returns true if the receiver $rcv is currently busy with incoming data,
+ or false otherwise.
+
+ "mlastsender"
+ mlastmsg $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.
+ It isn't cleared by "mreset".
+
+ "mlastmsg"
+ mlastmsg $rcv
+
+ Holds the last message received by $rcv, or "undef" if no message has
+ arrived yet. It isn't cleared by "mreset".
EXPORT
- This module exports on request its two only functions, "msend" and
- "mrecv".
+ This module exports any of its functions only on request.
PROTOCOL
Each byte of the data string is converted into its bits sequence, with
bits of highest weight coming first. All those bits sequences are put
- into the same order as the characters occur in the string. The emitter
- computes then the longuest sequence of successives 0 (say, m) and 1 (n).
- A signature is then chosen :
+ into the same order as the characters occur in the string.
+
+ The header is composed by the "utf8" bit (if the data has to be decoded
+ to UTF-8), the "sign" bit (if sender gives its PID in the header), and
+ then 24 bits representing the sender's PID (with highest weight coming
+ first) if the "sign" bit is set.
+
+ The emitter computes then the longuest sequence of successives 0 (say,
+ 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.
- The signal is then formed by concatenating the signature, the data bits
- and the reversed signature (i.e. the bits of the signature in the
- reverse order).
+ 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
+ in the reverse order).
+
+ a ... a b | u s [ p23 ... p0 ] | ... data ... | b a ... a
+ signature | header | data | reversed signature
The receiver knows that the signature has been sent when it has catched
at least one 0 and one 1. The signal is completely transferred when it
use POSIX qw/SIGUSR1 SIGUSR2/;
use Time::HiRes qw/usleep/;
+use constant PID_BITS => 24;
+
=head1 NAME
IPC::MorseSignals - Communicate between processes with Morse signals.
=head1 VERSION
-Version 0.05
+Version 0.06
=cut
-our $VERSION = '0.05';
+our $VERSION = '0.06';
=head1 SYNOPSIS
if (!defined $pid) {
die "fork() failed: $!";
} elsif ($pid == 0) {
- local @SIG{qw/USR1 USR2/} = mrecv sub {
- print STDERR "received $_[0]!\n";
+ my $s = mrecv local %SIG, cb => sub {
+ print STDERR "received $_[1] from $_[0]!\n";
exit
};
1 while 1;
=head2 C<msend>
- msend $msg, $pid [, speed => $speed, utf8 => $utf8 ]
+ msend $msg, $pid [, speed => $speed, utf8 => $utf8, 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. If the C<utf8> flag is set, the string will first be encoded in UTF-8. In this case, you must turn it on for L</mrecv> as well.
-Default speed is 512, don't set it too low or the target will miss bits and the whole message will be crippled. The C<utf8> flag is turned off by default.
+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.
=cut
sub msend {
my ($msg, $pid, @o) = @_;
- my @pid = (ref $pid eq 'ARRAY') ? @$pid : $pid;
+ my @pids = (ref $pid eq 'ARRAY') ? @$pid : $pid;
return unless defined $msg && length $msg;
- croak 'No PID was supplied' unless @pid;
+ croak 'No PID was supplied' unless @pids;
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};
my $delay = int(1_000_000 / $opts{speed});
+
+ my @head = (
+ ($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;
+ }
+
my $tpl = 'B*';
if ($opts{utf8}) {
utf8::encode $msg;
$tpl = 'U0' . $tpl;
}
my @bits = split //, unpack $tpl, $msg;
+
+ unshift @bits, @head;
my ($c, $n, @l) = (2, 0, 0, 0, 0);
for (@bits) {
if ($c == $_) {
($c, $n) = ($l[0] > $l[1]) ? (1, $l[1]) : (0, $l[0]); # Take the smallest
++$n;
@bits = (($c) x $n, 1 - $c, @bits, 1 - $c, ($c) x $n);
+
for (@bits) {
my $sig = ($_ == 0) ? SIGUSR1 : SIGUSR2;
usleep $delay;
- kill $sig, @pid;
+ kill $sig => @pids;
}
}
=head2 C<mrecv>
- mrecv $callback [, utf => $utf8 ]
+ mrecv %SIG [, cb => $callback ]
-Takes as its first argument the callback triggered when a complete message is received, and returns two code references that should replace C<USR1> and C<USR2> signal handlers. Basically, you want to use it like this :
+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<cb> specifies the callback to trigger each time a complete message has arrived. Basically, you want to use it like this :
- local @SIG{qw/USR1 USR2/} = mrecv sub { ... };
+ my $rv = mrecv local %SIG, cb => sub { ... };
-Turn on the utf8 flag if you know that the incoming strings are expected to be in UTF-8. This flag is turned off by default.
+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.
=cut
-sub mrecv {
- my ($cb, @o) = @_;
- croak 'No callback was specified' unless $cb;
+sub mreset;
+
+sub mrecv (\%@) {
+ my ($sig, @o) = @_;
croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
my %opts = @o;
- $opts{utf8} ||= 0;
- my ($bits, $state, $c, $n, $end) = ('', 0, undef, 0, '');
+ my $s = { cb => $opts{cb} };
+ mreset $s;
+
my $sighandler = sub {
my ($b) = @_;
- if ($state == 2) {
- if (defined $bits && (substr $bits, -$n) eq $end) { # done
- substr $bits, -$n, $n, '';
+
+ if ($s->{state} == 5) { # data
+
+ $s->{bits} .= $b;
+ if ((substr $s->{bits}, - $s->{n}) eq $s->{end}) {
+ substr $s->{bits}, - $s->{n}, $s->{n}, '';
my $tpl = 'B*';
- $tpl = 'U0' . $tpl if $opts{utf8};
- my $msg = pack $tpl, $bits;
- $cb->($msg);
+ $tpl = 'U0' . $tpl if $s->{utf8};
+ $s->{msg} = pack $tpl, $s->{bits};
+ mreset $s;
+ $s->{cb}->(@{$s}{qw/sender msg/}) if $s->{cb};
}
- } elsif ($state == 1) {
- if ($c != $b) {
- $state = 2;
- $end = (1 - $c) . $c x $n;
- $bits = '';
+
+ } elsif ($s->{state} == 4) { # sender signature
+
+ if (length $s->{bits} < PID_BITS) {
+ $s->{bits} .= $b;
+ } else {
+ my $n = 2 ** PID_BITS;
+ my @b = split //, $s->{bits};
+ $s->{sender} += $n * shift @b while ($n /= 2) >= 1;
+ @{$s}{qw/state bits/} = (5, $b);
}
- ++$n;
- } else {
- $c = $b;
- $n = 1;
- $state = 1;
+
+ } elsif ($s->{state} == 3) { # signature flag
+
+ @{$s}{qw/state sign/} = ($b ? 4 : 5, $b);
+
+ } elsif ($s->{state} == 2) { # utf8 flag
+
+ @{$s}{qw/state utf8/} = (3, $b);
+
+ } elsif ($s->{state} == 1) { # end of signature
+
+ if ($s->{c} != $b) {
+ @{$s}{qw/state end/} = (2, (1 - $s->{c}) . $s->{c} x $s->{n});
+ }
+ ++$s->{n};
+
+ } else { # first bit
+
+ @{$s}{qw/state c n sender msg/} = (1, $b, 1, 0, '');
+
}
+
};
- return sub {
- $bits .= 0;
- $sighandler->(0);
- }, sub {
- $bits .= 1;
- $sighandler->(1);
- };
+
+ @{$sig}{qw/USR1 USR2/} = (sub { $sighandler->(0) }, sub { $sighandler->(1) });
+
+ return $s;
+}
+
+=head2 C<mreset>
+
+ mreset $rcv
+
+Resets the state of the receiver C<$rcv>. Useful to abort transfers.
+
+=cut
+
+sub mreset {
+ my ($rcv) = @_;
+ @{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0);
+}
+
+=head2 C<mbusy>
+
+ mbusy $rcv
+
+Returns true if the receiver C<$rcv> is currently busy with incoming data, or false otherwise.
+
+=cut
+
+sub mbusy {
+ my ($rcv) = @_;
+ return $rcv->{state} > 0;
+}
+
+=head2 C<mlastsender>
+
+ mlastmsg $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<undef> if no message has arrived yet. It isn't cleared by L</mreset>.
+
+=cut
+
+sub mlastsender {
+ my ($rcv) = @_;
+ return $rcv->{sender};
+}
+
+=head2 C<mlastmsg>
+
+ mlastmsg $rcv
+
+Holds the last message received by C<$rcv>, or C<undef> if no message has arrived yet. It isn't cleared by L</mreset>.
+
+=cut
+
+sub mlastmsg {
+ my ($rcv) = @_;
+ return $rcv->{msg};
}
=head1 EXPORT
-This module exports on request its two only functions, L</msend> and L</mrecv>.
+This module exports any of its functions only on request.
=cut
use base qw/Exporter/;
our @EXPORT = ();
-our %EXPORT_TAGS = ( 'funcs' => [ qw/msend mrecv/ ] );
+our %EXPORT_TAGS = ( 'funcs' => [ qw/msend mrecv mreset mbusy mlastsender mlastmsg/ ] );
our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
$EXPORT_TAGS{'all'} = \@EXPORT_OK;
=head1 PROTOCOL
-Each byte of the data string is converted into its bits sequence, with bits of highest weight coming first. All those bits sequences are put into the same order as the characters occur in the string. The emitter computes then the longuest sequence of successives 0 (say, m) and 1 (n). A signature is then chosen :
+Each byte of the data string is converted into its bits sequence, with bits of highest weight coming first. All those bits sequences are put into the same order as the characters occur in the string.
+
+The header is composed by the C<utf8> bit (if the data has to be decoded to UTF-8), the C<sign> bit (if sender gives its PID in the header), and then 24 bits representing the sender's PID (with highest weight coming first) if the C<sign> bit is set.
+
+The emitter computes then the longuest sequence of successives 0 (say, m) and 1 (n) in the concatenation of the header and the data. A signature is then chosen :
=over 4
=back
-The signal is then formed by concatenating the signature, the data bits and the reversed signature (i.e. the bits of the signature in the reverse order).
+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 in the reverse order).
+
+ a ... a b | u s [ p23 ... p0 ] | ... data ... | b a ... a
+ signature | header | data | reversed signature
The receiver knows that the signature has been sent when it has catched at least one 0 and one 1. The signal is completely transferred when it has received for the first time the whole reversed signature.
use strict;
use warnings;
-use POSIX qw/SIGINT SIGTERM SIGKILL EXIT_SUCCESS EXIT_FAILURE WIFEXITED WEXITSTATUS/;
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
use lib qw{blib/lib};
-use IPC::MorseSignals qw/msend mrecv/;
+use IPC::MorseSignals qw/msend mrecv mreset/;
+
+my $lives = 100;
+
+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 $s = mrecv local %SIG, cb => sub {
+ select $wtr; $| = 1;
+ print $wtr $_[1], "\n";
+ select $wtr; $| = 1;
+ };
+ $SIG{'HUP'} = sub { mreset $s };
+ 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;
+}
my @res;
-sub tryspeed {
+my ($pid, $rdr) = spawn;
+
+sub tryspeed {
my ($l, $n) = @_;
my $speed = 2 ** 16;
my $ok = 0;
- my $desc;
-SPEED:
- while (($speed > 1) && ($ok < $n)) {
- $speed /= 2;
- $desc = "$n sends of $l bytes at $speed bits/s";
- $ok = 0;
- print STDERR "try $desc";
+ my @alpha = ('a' .. 'z');
+ my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
+ while (($ok < $n) && (($speed /= 2) >= 1)) {
+ print STDERR "$n sends of $l bytes at $speed bits/s";
+TRY:
for (1 .. $n) {
- print STDERR ".";
- my @alpha = ('a' .. 'z');
- my $msg = join '', map { $alpha[rand @alpha] } 1 .. $l;
- my $pid = fork;
- if (!defined $pid) {
- die "$desc: fork() failed : $!";
- } elsif ($pid == 0) {
- local @SIG{qw/USR1 USR2/} = mrecv sub {
- exit(($msg eq $_[0]) ? EXIT_SUCCESS : EXIT_FAILURE);
- };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- my $next = 0;
+ print STDERR '.';
+ my $r = '';
eval {
- local $SIG{ALRM} = sub { die 'timeout' };
+ local $SIG{ALRM} = sub { print STDERR "timeout\n"; die };
my $a = (int(100 * (3 * $l) / $speed) || 1);
$a = 10 if $a > 10;
alarm $a;
msend $msg => $pid, speed => $speed;
- waitpid $pid, 0;
- if (WIFEXITED($?) && (WEXITSTATUS($?) == EXIT_SUCCESS)) {
+ $r = <$rdr>;
+ };
+ kill SIGHUP => $pid if $@;
+ alarm 0;
+ if (!defined $r) { # Something bad happened, respawn
+ print STDERR "oops\n";
+ 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 {
- print STDERR " transfer error\n";
- $next = 1;
+ print STDERR "transfer error\n";
+ kill SIGHUP => $pid;
+ last TRY;
}
- };
- alarm 0;
- if ($@) {
- kill SIGINT, $pid;
- kill SIGTERM, $pid;
- kill SIGKILL, $pid;
- print STDERR " timeout\n";
- $next = 1;
}
- next SPEED if $next;
}
}
- $desc = "$l bytes sent $n times";
+ my $desc = "$l bytes sent $n times";
if ($speed >= 1) {
print STDERR " OK\n\n";
push @res, "$desc at $speed bits/s";
}
}
-tryspeed 4, 1;
-tryspeed 4, 4;
-tryspeed 4, 16;
-tryspeed 4, 64;
-tryspeed 4, 256;
-tryspeed 16, 1;
-tryspeed 16, 4;
-tryspeed 16, 16;
-tryspeed 16, 64;
-tryspeed 64, 1;
-tryspeed 64, 4;
-tryspeed 64, 16;
-tryspeed 256, 1;
-tryspeed 256, 4;
+tryspeed 4, 1;
+tryspeed 4, 4;
+tryspeed 4, 16;
+tryspeed 4, 64;
+tryspeed 4, 256;
+tryspeed 16, 1;
+tryspeed 16, 4;
+tryspeed 16, 16;
+tryspeed 16, 64;
+tryspeed 64, 1;
+tryspeed 64, 4;
+tryspeed 64, 16;
+tryspeed 256, 1;
+tryspeed 256, 4;
tryspeed 1024, 1;
print STDERR "=== Summary ===\n";
if (!defined $pid) {
die "fork() failed : $!";
} elsif ($pid == 0) {
- local @SIG{qw/USR1 USR2/} = mrecv sub { print STDERR "recieved: $_[0]"; exit };
- print STDERR "child wait for data...\n";
+ my $s = mrecv local %SIG, cb => sub {
+ print STDERR "I, the child, recieved this from $_[0]: $_[1]\n";
+ exit
+ };
+ print STDERR "I'm $$ (the child), and I'm waiting for data...\n";
1 while 1;
}
-msend "This message was sent with IPC::MorseSignals\n" => $pid;
+print STDERR "I'm $$ (the father), and I'm gonna send a message to my child $pid.\n";
+
+msend "This message was sent with IPC::MorseSignals" => $pid;
waitpid $pid, 0;
#!perl -T
-use Test::More tests => 2;
+use Test::More tests => 6;
require IPC::MorseSignals;
-for (qw/msend mrecv/) {
+for (qw/msend mrecv mreset mbusy mlastsender mlastmsg/) {
eval { Variable::Magic->import($_) };
ok(!$@, 'import ' . $_);
}
use POSIX qw/SIGINT SIGTERM SIGKILL EXIT_SUCCESS EXIT_FAILURE WIFEXITED WEXITSTATUS/;
-sub trysig {
- my ($n, $s) = @_;
- my $pid = fork;
- if (!defined $pid) {
- die "$s: fork() failed : $!";
- } elsif ($pid == 0) {
- local $SIG{$s} = sub { exit EXIT_SUCCESS };
- 1 while 1;
- exit EXIT_FAILURE;
- }
- sleep 1;
- my $ret = 0;
- eval {
- local $SIG{ALRM} = sub { die };
- alarm 1;
- kill $n, $pid;
- waitpid $pid, 0;
- $ret = (WIFEXITED($?) && (WEXITSTATUS($?) == EXIT_SUCCESS));
- alarm 0;
- };
- if ($@) {
- kill SIGINT, $pid;
- kill SIGTERM, $pid;
- kill SIGKILL, $pid;
- die "$s: $@";
- }
- ok($ret, $s);
-}
+my ($a, $b) = (0, 0);
-trysig SIGUSR1, 'USR1';
-trysig SIGUSR2, 'USR2';
+local $SIG{'USR1'} = sub { ++$a };
+local $SIG{'USR2'} = sub { ++$b };
+
+kill SIGUSR1 => $$;
+ok(($a == 1) && ($b == 0), 'SIGUSR1');
+
+kill SIGUSR2 => $$;
+ok(($a == 1) && ($b == 1), 'SIGUSR2');
--- /dev/null
+#!perl -T
+
+use Test::More tests => 2;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use IPC::MorseSignals qw/msend mrecv mreset/;
+
+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;
+}
+
+my ($pid, $rdr) = spawn;
+
+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);
+}
+
+trysend 0, 'anonymous';
+trysend 1, 'signed';
+
+slaughter $pid;
--- /dev/null
+#!perl -T
+
+use Test::More tests => 4 * 3;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use IPC::MorseSignals qw/msend mrecv mreset/;
+
+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 $_[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;
+}
+
+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;
--- /dev/null
+#!perl -T
+
+use Test::More tests => 7 * 3;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use IPC::MorseSignals qw/msend mrecv mreset/;
+
+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;
+
+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);
+}
+
+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';
+}
+
+slaughter $pid;
--- /dev/null
+#!perl -T
+
+use Test::More tests => 10;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_SUCCESS EXIT_FAILURE/;
+
+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;
+}
+
+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');
+}
+
+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;
+
+slaughter $pid;
+
+diag '=== Summary ===';
+diag $_ for sort {
+ my ($l1, $n1) = $a =~ /(\d+)\D+(\d+)/;
+ my ($l2, $n2) = $b =~ /(\d+)\D+(\d+)/;
+ $l1 <=> $l2 || $n1 <=> $n2
+} @res;
projects / perl / modules / IPC-MorseSignals.git / commitdiff