--- /dev/null
+Revision history for IPC-MorseSignals
+
+0.10 2008-03-05 16:35 UTC
+ IPC::MorseSignals now uses Bit::MorseSignals as backend. Major rewrite.
+
+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
+ 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.
+ + Doc : Typos in POD.
+
+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.
+ + Doc : Typos in POD.
+ + Fix : You can now send "0" as a valid message.
+ + Fix : I lied, t/02-sigusr.t wasn't really gone.
+ + Fix : while ($speed > 1) { $speed /= 2 } ok($speed >= 1); never fails.
+
+0.04 2007-08-17 14:45 UTC
+ + Add : Test for SUGUSR{1,2} in Makefile.PL.
+ + Add : Unicode support. Enabled by passing utf8 => 1 to m{send,recv}.
+ + Chg : The speed must now be passed to msend() by speed => $speed.
+ + Chg : Tests no longer pass their result with pipes.
+ + Doc : <apeiron> Prof_Vince, 'truely' isn't a word.
+ + Fix : t/11-speed.t didn't fail properly (as if those tests don't fail
+ enough yet!).
+ + Fix : t/02-sigusr.t didn't check properly the returned value.
+
+0.03 2007-08-16 16:20 UTC
+ + Chg : Better t/10-base.t... Or at least, I hope so.
+
+0.02 2007-08-16 15:55 UTC
+ + Add : samples/bench.pl, a transfer speed benchmark script.
+ + Add : New tests : t/02-sigusr.t, t/11-speed.t
+ + Fix : Warnings when the transfer fails.
+ + Doc : The protocol was documented.
+
+0.01 2007-08-15 21:20 UTC
+ First version, released on an unsuspecting world.
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/IPC/MorseSignals.pm
+lib/IPC/MorseSignals/Emitter.pm
+lib/IPC/MorseSignals/Receiver.pm
+samples/bench.pl
+samples/try.pl
+t/00-load.t
+t/02-can.t
+t/10-sigusr.t
+t/20-emitter-obj.t
+t/30-receiver-obj.t
+t/50-self-plain.t
+t/51-self-utf8.t
+t/52-self-storable.t
+t/60-fork-plain.t
+t/61-fork-utf8.t
+t/62-fork-storable.t
+t/70-speed.t
+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
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: IPC-MorseSignals
+version: 0.10
+abstract: Communicate between processes with Morse signals.
+license: perl
+author:
+ - Vincent Pit <perl@profvince.com>
+generated_by: ExtUtils::MakeMaker version 6.44
+distribution_type: module
+requires:
+ Carp: 0
+ Exporter: 0
+ POSIX: 0
+ Test::More: 0
+ Time::HiRes: 0
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+build_requires:
+ Data::Dumper: 0
+ Exporter: 0
+ ExtUtils::MakeMaker: 0
+ POSIX: 0
+ Test::More: 0
+ utf8: 0
--- /dev/null
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+BEGIN {
+ eval { require Config };
+ die "You need the Config module to install this distribution, that's what happened" if $@;
+ Config->import qw/%Config/;
+}
+
+my %sigs;
+@sigs{split ' ', $Config{sig_name}} = ();
+
+for (qw/USR1 USR2/) {
+ print "Checking if you have SIG$_... ";
+ unless (exists $sigs{$_}) {
+ print "no\n";
+ die "Installation stops right here,";
+ }
+ print "yes\n";
+}
+
+my $BUILD_REQUIRES = {
+ 'utf8' => 0,
+ 'Data::Dumper' => 0,
+ 'Exporter' => 0,
+ 'ExtUtils::MakeMaker' => 0,
+ 'POSIX' => 0,
+ 'Test::More' => 0,
+};
+
+sub build_req {
+ my $tometa = ' >> $(DISTVNAME)/META.yml;';
+ my $build_req = 'echo "build_requires:" ' . $tometa;
+ foreach my $mod ( sort { lc $a cmp lc $b } keys %$BUILD_REQUIRES ) {
+ my $ver = $BUILD_REQUIRES->{$mod};
+ $build_req .= sprintf 'echo " %-30s %s" %s', "$mod:", $ver, $tometa;
+ }
+ return $build_req;
+}
+
+WriteMakefile(
+ NAME => 'IPC::MorseSignals',
+ AUTHOR => 'Vincent Pit <perl@profvince.com>',
+ LICENSE => 'perl',
+ VERSION_FROM => 'lib/IPC/MorseSignals.pm',
+ ABSTRACT_FROM => 'lib/IPC/MorseSignals.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Carp' => 0,
+ 'Exporter' => 0,
+ 'POSIX' => 0,
+ 'Test::More' => 0,
+ 'Time::HiRes' => 0,
+ },
+ dist => {
+ PREOP => 'pod2text lib/IPC/MorseSignals.pm > $(DISTVNAME)/README; '
+ . build_req,
+ COMPRESS => 'gzip -9f', SUFFIX => 'gz',
+ },
+ clean => { FILES => 'IPC-MorseSignals-*' },
+);
--- /dev/null
+NAME
+ IPC::MorseSignals - Communicate between processes with Morse signals.
+
+VERSION
+ Version 0.10
+
+SYNOPSIS
+ # In the sender process
+ use IPC::MorseSignals::Emitter;
+
+ my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+ $deuce->post('HLAGH') for 1 .. 3;
+ $deuce->send($pid);
+
+ ...
+
+ # In the receiver process
+ use IPC::MorseSignals::Receiver;
+
+ local %SIG;
+ my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ print STDERR "GOT $_[1]\n";
+ };
+
+ head1 DESCRIPTION
+
+ This module implements a rare form of IPC by sending Morse-like signals
+ through "SIGUSR1" and "SIGUSR2". Both of those signals are used, so you
+ won't be able to keep them for something else when you use this module.
+
+ IPC::MorseSignals::Emitter is a base class for emitters ;
+ IPC::MorseSignals::Receiver is a base class for receivers ;
+
+ But, seriously, use something else for your IPC. :)
+
+DEPENDENCIES
+ You need the complete Bit::MorseSignals distribution.
+
+ Carp (standard since perl 5), POSIX (idem) and Time::HiRes (since perl
+ 5.7.3) are also required.
+
+SEE ALSO
+ IPC::MorseSignals::Emitter, IPC::MorseSignals::Receiver.
+
+ Bit::MorseSignals, Bit::MorseSignals::Emitter,
+ Bit::MorseSignals::Receiver.
+
+ perlipc for information about signals in perl.
+
+ For truly useful IPC, search for shared memory, pipes and semaphores.
+
+AUTHOR
+ Vincent Pit, "<perl at profvince.com>", <http://www.profvince.com>.
+
+ You can contact me by mail or on #perl @ FreeNode (vincent or
+ Prof_Vince).
+
+BUGS
+ Please report any bugs or feature requests to "bug-ipc-morsesignals at
+ rt.cpan.org", or through the web interface at
+ <http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>. I
+ will be notified, and then you'll automatically be notified of progress
+ on your bug as I make changes.
+
+SUPPORT
+ You can find documentation for this module with the perldoc command.
+
+ perldoc IPC::MorseSignals
+
+ACKNOWLEDGEMENTS
+ Thanks for the inspiration, mofino ! I hope this module will fill all
+ your IPC needs. :)
+
+COPYRIGHT & LICENSE
+ Copyright 2007-2008 Vincent Pit, all rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
--- /dev/null
+package IPC::MorseSignals;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+IPC::MorseSignals - Communicate between processes with Morse signals.
+
+=head1 VERSION
+
+Version 0.10
+
+=cut
+
+our $VERSION = '0.10';
+
+=head1 SYNOPSIS
+
+ # In the sender process
+ use IPC::MorseSignals::Emitter;
+
+ my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+ $deuce->post('HLAGH') for 1 .. 3;
+ $deuce->send($pid);
+
+ ...
+
+ # In the receiver process
+ use IPC::MorseSignals::Receiver;
+
+ local %SIG;
+ my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ print STDERR "GOT $_[1]\n";
+ };
+
+head1 DESCRIPTION
+
+This module implements a rare form of IPC by sending Morse-like signals through C<SIGUSR1> and C<SIGUSR2>. Both of those signals are used, so you won't be able to keep them for something else when you use this module.
+
+=over 4
+
+=item L<IPC::MorseSignals::Emitter> is a base class for emitters ;
+
+=item L<IPC::MorseSignals::Receiver> is a base class for receivers ;
+
+=back
+
+But, seriously, use something else for your IPC. :)
+
+=head1 DEPENDENCIES
+
+You need the complete L<Bit::MorseSignals> distribution.
+
+L<Carp> (standard since perl 5), L<POSIX> (idem) and L<Time::HiRes> (since perl 5.7.3) are also required.
+
+=head1 SEE ALSO
+
+L<IPC::MorseSignals::Emitter>, L<IPC::MorseSignals::Receiver>.
+
+L<Bit::MorseSignals>, L<Bit::MorseSignals::Emitter>, L<Bit::MorseSignals::Receiver>.
+
+L<perlipc> for information about signals in perl.
+
+For truly useful IPC, search for shared memory, pipes and semaphores.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-ipc-morsesignals at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc IPC::MorseSignals
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007-2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of IPC::MorseSignals
--- /dev/null
+package IPC::MorseSignals::Emitter;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+use POSIX qw/SIGUSR1 SIGUSR2/;
+use Time::HiRes qw/usleep/;
+
+use Bit::MorseSignals::Emitter;
+use base qw/Bit::MorseSignals::Emitter/;
+
+=head1 NAME
+
+IPC::MorseSignals::Emitter - Base class for IPC::MorseSignals emitters.
+
+=head1 VERSION
+
+Version 0.10
+
+=cut
+
+our $VERSION = '0.10';
+
+=head1 SYNOPSIS
+
+ use IPC::MorseSignals::Emitter;
+
+ my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+ $deuce->post('HLAGH') for 1 .. 3;
+ $deuce->send($pid);
+
+=head1 DESCRIPTION
+
+This module sends messages processed by a L<Bit::MorseSignal> emitter to another process as C<SIGUSR1> (for bits 0) and C<SIGUSR2> (for 1) signals.
+
+=cut
+
+sub _check_self {
+ croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
+ unless ref $_[0] and $_[0]->isa(__PACKAGE__);
+}
+
+=head1 METHODS
+
+=head2 C<< new < delay => $seconds, speed => $bauds, %bme_options > >>
+
+Creates a new emitter object. C<delay> specifies the delay between two sends, in seconds, while C<speed> is the number of bits sent per second. The delay value has priority over the speed. Extra arguments are passed to L<Bit::MorseSignals::Emitter/new>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref $class || $class || return;
+ croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
+ my %opts = @_;
+ # delay supersedes speed
+ my $delay = delete $opts{delay}; # fractional seconds
+ if (!defined $delay) {
+ my $speed = delete $opts{speed} || 0; # bauds
+ $speed = int $speed;
+ $delay = abs(1 / $speed) if $speed;
+ }
+ my $self = $class->SUPER::new(%opts);
+ $self->{delay} = abs($delay || 1 + 0.0);
+ bless $self, $class;
+}
+
+=head2 C<send $pid>
+
+Sends messages enqueued with L<Bit::MorseSignals::Emitter/post> to the process C<$pid> (or to all the C<@$pid> if C<$pid> is an array reference).
+
+=cut
+
+sub send {
+ my ($self, $dest) = @_;
+ _check_self($self);
+ return unless defined $dest;
+ my @dests = grep $_ > 0, ref $dest eq 'ARRAY' ? map int, grep defined, @$dest
+ : int $dest;
+ while (defined(my $bit = $self->pop)) {
+ my @sigs = (SIGUSR1, SIGUSR2);
+ my $d = $self->{delay} * 1_000_000;
+ $d -= usleep $d while $d > 0;
+ kill $sigs[$bit] => @dests;
+ }
+ return unless @dests;
+}
+
+=head2 C<< delay < $seconds > >>
+
+Returns the current delay in seconds, or set it if an argument is provided.
+
+=cut
+
+sub delay {
+ my ($self, $delay) = @_;
+ _check_self($self);
+ $self->{delay} = abs $delay if $delay and $delay += 0.0;
+ return $self->{delay};
+}
+
+=head2 C<< speed < $bauds > >>
+
+Returns the current speed in bauds, or set it if an argument is provided.
+
+=cut
+
+sub speed {
+ my ($self, $speed) = @_;
+ _check_self($self);
+ $self->{delay} = 1 / (abs $speed) if $speed and $speed = int $speed;
+ return int(1 / $self->{delay});
+}
+
+=pod
+
+IPC::MorseSignals::Emitter objects also inherit methods from L<Bit::MorseSignals::Emitter>.
+
+=head1 EXPORT
+
+An object module shouldn't export any function, and so does this one.
+
+=head1 DEPENDENCIES
+
+L<Bit::MorseSignals::Emitter>.
+
+L<Carp> (standard since perl 5), L<POSIX> (idem) and L<Time::HiRes> (since perl 5.7.3) are required.
+
+=head1 SEE ALSO
+
+L<IPC::MorseSignals>, L<IPC::MorseSignals::Receiver>.
+
+L<Bit::MorseSignals>, L<Bit::MorseSignals::Emitter>, L<Bit::MorseSignals::Receiver>.
+
+L<perlipc> for information about signals in perl.
+
+For truly useful IPC, search for shared memory, pipes and semaphores.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-ipc-morsesignals-emitter at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc IPC::MorseSignals::Emitter
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007-2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of IPC::MorseSignals::Emitter
--- /dev/null
+package IPC::MorseSignals::Receiver;
+
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+
+use Bit::MorseSignals::Receiver;
+use base qw/Bit::MorseSignals::Receiver/;
+
+=head1 NAME
+
+IPC::MorseSignals::Receiver - Base class for IPC::MorseSignals receivers.
+
+=head1 VERSION
+
+Version 0.10
+
+=cut
+
+our $VERSION = '0.10';
+
+=head1 SYNOPSIS
+
+ use IPC::MorseSignals::Receiver;
+
+ local %SIG;
+ my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ print STDERR "GOT $_[1]\n";
+ };
+
+=head1 DESCRIPTION
+
+This module installs C<$SIG{qw/USR1 USR2/}> handlers and forwards the bits received to a L<Bit::MorseSignal> receiver.
+
+=head1 METHODS
+
+=head2 C<new>
+
+Creates a new receiver object. Its arguments are passed to L<Bit::MorseSignals::Receiver/new>, in particular the C<done> callback.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $sig = shift;
+ $class = ref $class || $class || return;
+ croak 'The first argument must be a hash reference to the %SIG hash'
+ unless $sig and ref $sig eq 'HASH';
+ my $self = bless $class->SUPER::new(@_), $class;
+ @{$sig}{qw/USR1 USR2/} = (sub { $self->push(0) }, sub { $self->push(1) });
+ return $self;
+}
+
+=pod
+
+IPC::MorseSignals::Receiver objects also inherit methods from L<Bit::MorseSignals::Receiver>.
+
+=head1 EXPORT
+
+An object module shouldn't export any function, and so does this one.
+
+=head1 DEPENDENCIES
+
+L<Bit::MorseSignals::Receiver>.
+
+L<Carp> (standard since perl 5) is also required.
+
+=head1 SEE ALSO
+
+L<IPC::MorseSignals>, L<IPC::MorseSignals::Emitter>.
+
+L<Bit::MorseSignals>, L<Bit::MorseSignals::Emitter>, L<Bit::MorseSignals::Receiver>.
+
+L<perlipc> for information about signals in perl.
+
+For truly useful IPC, search for shared memory, pipes and semaphores.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-ipc-morsesignals-receiver at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc IPC::MorseSignals::Receiver
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007-2008 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of IPC::MorseSignals::Receiver
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use POSIX qw/SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use lib qw{blib/lib t/lib};
+
+use IPC::MorseSignals::TestSuite qw/init bench cleanup/;
+
+my $diag = sub { print STDERR "@_\n" };
+my @res;
+
+init 100;
+
+bench 4, 1, $diag, \@res;
+bench 4, 4, $diag, \@res;
+bench 4, 16, $diag, \@res;
+bench 4, 64, $diag, \@res;
+bench 4, 256, $diag, \@res;
+bench 16, 1, $diag, \@res;
+bench 16, 4, $diag, \@res;
+bench 16, 16, $diag, \@res;
+bench 16, 64, $diag, \@res;
+bench 64, 1, $diag, \@res;
+bench 64, 4, $diag, \@res;
+bench 64, 16, $diag, \@res;
+bench 256, 1, $diag, \@res;
+bench 256, 4, $diag, \@res;
+bench 1024, 1, $diag, \@res;
+
+cleanup;
+
+print STDERR "=== Summary ===\n";
+print STDERR "$_\n" for @res;
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use POSIX qw/pause EXIT_SUCCESS EXIT_FAILURE/;
+
+use lib qw{blib/lib};
+
+use IPC::MorseSignals::Emitter;
+use IPC::MorseSignals::Receiver;
+
+my $pid = fork;
+if (!defined $pid) {
+ die "fork() failed : $!";
+} elsif ($pid == 0) {
+ local %SIG;
+ my $rcv = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ print STDERR "I, the child, recieved this : $_[1]\n";
+ exit EXIT_SUCCESS;
+ };
+ print STDERR "I'm $$ (the child), and I'm waiting for data...\n";
+ pause while 1;
+ exit EXIT_FAILURE;
+}
+
+print STDERR "I'm $$ (the parent), and I'm gonna send a message to my child $pid.\n";
+
+my $snd = new IPC::MorseSignals::Emitter speed => 1000;
+$snd->post("This message was sent with IPC::MorseSignals");
+$snd->send($pid);
+waitpid $pid, 0;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok( 'IPC::MorseSignals' );
+ use_ok( 'IPC::MorseSignals::Emitter' );
+ use_ok( 'IPC::MorseSignals::Receiver' );
+}
+
+diag( "Testing IPC::MorseSignals $IPC::MorseSignals::VERSION, Perl $], $^X" );
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 10 + 7;
+
+require IPC::MorseSignals::Emitter;
+
+for (qw/new post pop reset flush busy queued/, qw/new send delay speed/) {
+ ok(IPC::MorseSignals::Emitter->can($_), 'IME can ' . $_);
+}
+
+require IPC::MorseSignals::Receiver;
+
+for (qw/new push reset busy msg/, qw/new/) {
+ ok(IPC::MorseSignals::Receiver->can($_), 'IMR can ' . $_);
+}
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use POSIX qw/SIGUSR1 SIGUSR2/;
+
+my ($a, $b) = (0, 0);
+
+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 strict;
+use warnings;
+
+use Test::More tests => 19;
+
+use IPC::MorseSignals::Emitter;
+
+my $deuce = new IPC::MorseSignals::Emitter;
+ok(defined $deuce, 'BME object is defined');
+ok(ref $deuce eq 'IPC::MorseSignals::Emitter', 'IME object is valid');
+ok($deuce->isa('Bit::MorseSignals::Emitter'), 'IME is a BME');
+
+my $fake = { };
+bless $fake, 'IPC::MorseSignal::Hlagh';
+eval { IPC::MorseSignals::Emitter::speed($fake) };
+ok($@ && $@ =~ /^First\s+argument/, "IME methods only apply to IME objects");
+eval { Bit::MorseSignals::Emitter::reset($fake) };
+ok($@ && $@ =~ /^First\s+argument/, "BME methods only apply to BME objects");
+
+ok($deuce->delay == 1, 'default delay is 1');
+ok($deuce->speed == 1, 'default speed is 1');
+
+$deuce->delay(0.1);
+ok(abs($deuce->delay - 0.1) < 0.01, 'set delay is 0.1');
+ok($deuce->speed == 10, 'resulting speed is 10');
+
+$deuce->speed(100);
+ok($deuce->speed == 100, 'set speed is 100');
+ok(abs($deuce->delay - 0.01) < 0.001, 'resulting speed is 0.01');
+
+$deuce = new IPC::MorseSignals::Emitter delay => 0.25;
+ok(abs($deuce->delay - 0.25) < 0.025, 'initial delay is 0.25');
+ok($deuce->speed == 4, 'resulting initial speed is 4');
+
+$deuce = new IPC::MorseSignals::Emitter speed => 40;
+ok($deuce->speed == 40, 'initial speed is 40');
+ok(abs($deuce->delay - 0.025) < 0.0025, 'resulting initial delay is 0.025');
+
+$deuce = new IPC::MorseSignals::Emitter delay => 0.25, speed => 40;
+ok(abs($deuce->delay - 0.25) < 0.025, 'delay supersedes speed');
+
+$deuce = new IPC::MorseSignals::Emitter delay => 0;
+ok($deuce->delay == 1, 'wrong delay results in 1');
+
+$deuce = new IPC::MorseSignals::Emitter speed => 0.1;
+ok($deuce->delay == 1, 'wrong speed results in 1');
+
+$deuce = new IPC::MorseSignals::Emitter delay => 0, speed => -0.1;
+ok($deuce->delay == 1, 'wrong delay and speed result in 1');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use IPC::MorseSignals::Receiver;
+
+my $pants = new IPC::MorseSignals::Receiver \%SIG;
+ok(defined $pants, 'IMR object is defined');
+ok(ref $pants eq 'IPC::MorseSignals::Receiver', 'IMR object is valid');
+ok($pants->isa('Bit::MorseSignals::Receiver'), 'IMR is a BMR');
+
+my $fake = { };
+bless $fake, 'IPC::MorseSignal::Hlagh';
+eval { Bit::MorseSignals::Receiver::reset($fake) };
+ok($@ && $@ =~ /^First\s+argument/, "BMR methods only apply to BMR objects");
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+use IPC::MorseSignals::Emitter;
+use IPC::MorseSignals::Receiver;
+
+my @msgs = qw/hlagh hlaghlaghlagh HLAGH HLAGHLAGHLAGH \x{0dd0}\x{00}
+ h\x{00}la\x{00}gh \x{00}\x{ff}\x{ff}\x{00}\x{00}\x{ff}/;
+
+my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ my $cur = shift @msgs;
+ ok($_[1] eq $cur, 'got ' . $_[1] . ', received ' . $cur)
+};
+
+$deuce->post($_) for @msgs;
+$deuce->send($$);
+
+ok(!$deuce->busy, 'emitter is no longer busy after all the messages have been sent');
+ok(!$pants->busy, 'receiver is no longer busy after all the messages have been got');
+
+ok(0, "didn't got $_") for @msgs;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use utf8;
+
+use Test::More tests => 7;
+
+use IPC::MorseSignals::Emitter;
+use IPC::MorseSignals::Receiver;
+
+my @msgs = qw/€éèë 月語 x tata たTÂ/;
+
+sub cp { join '.', map ord, split //, $_[0] }
+
+my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ my $cur = shift @msgs;
+ ok($_[1] eq $cur, 'got ' . cp($_[1]) . ', expected ' . cp($cur))
+};
+
+$deuce->post($_) for @msgs;
+$deuce->send($$);
+
+ok(!$deuce->busy, 'emitter is no longer busy after all the messages have been sent');
+ok(!$pants->busy, 'receiver is no longer busy after all the messages have been got');
+
+ok(0, 'didn\'t got ' . cp($_)) for @msgs;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use utf8;
+
+use Test::More tests => 10;
+
+use IPC::MorseSignals::Emitter;
+use IPC::MorseSignals::Receiver;
+
+my @msgs = (
+ \(undef, -273, 1.4159, 'yes', '¥€$'),
+ [ 5, 6, 7 ],
+ { hlagh => 1, HLAGH => 2 },
+ { lol => [ 'bleh', undef, 4684324 ] },
+);
+$msgs[7]->{wut} = { dong => [ 0 .. 9 ], recurse => $msgs[7] };
+my $i = 0;
+
+my $deuce = new IPC::MorseSignals::Emitter speed => 1024;
+my $pants = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ my $cur = shift @msgs;
+ is_deeply($_[1], $cur, 'got object ' . $i++);
+};
+
+$deuce->post($_) for @msgs;
+$deuce->send($$);
+
+ok(!$deuce->busy, 'emitter is no longer busy after all the messages have been sent');
+ok(!$pants->busy, 'receiver is no longer busy after all the messages have been got');
+
+ok(0, 'didn\'t got object ' . $i++) for @msgs;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+use lib 't/lib';
+use IPC::MorseSignals::TestSuite qw/try init cleanup/;
+
+sub test {
+ my ($desc, @args) = @_;
+ eval { ok(try(@args), $desc) };
+ fail($desc . " (died : $@)") if $@;
+}
+
+my @msgs = qw/hlagh hlaghlaghlagh HLAGH HLAGHLAGHLAGH \x{0dd0}\x{00}
+ h\x{00}la\x{00}gh \x{00}\x{ff}\x{ff}\x{00}\x{00}\x{ff}/;
+
+init 6;
+
+test 'plain' => $_ for @msgs;
+
+cleanup;
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use utf8;
+
+use Test::More tests => 5;
+
+use lib 't/lib';
+use IPC::MorseSignals::TestSuite qw/try init cleanup/;
+
+sub test {
+ my ($desc, @args) = @_;
+ eval { ok(try(@args), $desc) };
+ fail($desc . " (died : $@)") if $@;
+}
+
+my @msgs = qw/€éèë 月語 x tata たTÂ/;
+
+init 6;
+
+test 'plain' => $_ for @msgs;
+
+cleanup;
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use utf8;
+
+use Test::More tests => 8;
+
+use lib 't/lib';
+use IPC::MorseSignals::TestSuite qw/try init cleanup/;
+
+sub test {
+ my ($desc, @args) = @_;
+ eval { ok(try(@args), $desc) };
+ fail($desc . " (died : $@)") if $@;
+}
+
+my @msgs = (
+ \(undef, -273, 1.1, 'yes', '¥€$'),
+ [ 5, 6 ],
+ { hlagh => 1, HLAGH => 2 },
+ { x => -3.573 },
+);
+$msgs[7]->{y} = $msgs[7];
+
+init 6;
+
+test 'plain' => $_ for @msgs;
+
+cleanup;
+
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use utf8;
+
+use Test::More tests => 3;
+
+use lib 't/lib';
+use IPC::MorseSignals::TestSuite qw/bench init cleanup/;
+
+my $diag = sub { diag @_ };
+my @res;
+
+init 12;
+
+ok(bench(4, 1, $diag, \@res));
+ok(bench(4, 4, $diag, \@res));
+ok(bench(16, 1, $diag, \@res));
+
+cleanup;
+
+diag '=== Summary ===';
+diag $_ for sort {
+ my ($l1, $n1) = $a =~ /(\d+)\D+(\d+)/;
+ my ($l2, $n2) = $b =~ /(\d+)\D+(\d+)/;
+ $l1 <=> $l2 || $n1 <=> $n2
+} @res;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+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");
+ }
+}
+
+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]/,
+ );
+}
+
+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)
+);
+
+module_boilerplate_ok('lib/IPC/MorseSignals.pm');
+module_boilerplate_ok('lib/IPC/MorseSignals/Emitter.pm');
+module_boilerplate_ok('lib/IPC/MorseSignals/Receiver.pm');
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok(
+# also_private => [ qr/^_/ ]
+);
--- /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;
+
+plan(skip_all => 'XXX Testing with 5.8') if $^V lt v5.10;
+
+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 Data::Dumper;
+use POSIX qw/pause SIGINT SIGTERM SIGKILL SIGHUP EXIT_FAILURE/;
+
+use IPC::MorseSignals::Emitter;
+use IPC::MorseSignals::Receiver;
+
+use base qw/Exporter/;
+
+our @EXPORT_OK = qw/try bench init cleanup/;
+
+$Data::Dumper::Indent = 0;
+
+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 = new IPC::MorseSignals::Receiver \%SIG, done => sub {
+ print $wtr Dumper($_[1]), "\n";
+ };
+ my $ppid = getppid;
+ $SIG{ALRM} = sub { alarm 1; kill SIGHUP => $ppid };
+ alarm 1;
+ $SIG{HUP} = sub { alarm 0; $rcv->reset }; # We can reset the alarm here.
+ pause 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 }
+
+my $snd = new IPC::MorseSignals::Emitter;
+
+sub try {
+ my ($msg) = @_;
+ my $speed = 2 ** 16;
+ my $ok = 0;
+ my @ret;
+ while (!$ok && (($speed /= 2) >= 1)) {
+ my $r = '';
+ my $dump = Dumper($msg);
+ 1 while chomp $dump;
+ 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;
+ $snd->post($msg);
+ $snd->speed($speed);
+ $snd->send($pid);
+ $r = <$rdr>;
+ alarm 0;
+ };
+ if (!defined $r) { # Something bad happened, respawn
+ slaughter;
+ spawn;
+ } else {
+ 1 while chomp $r;
+ if ($r eq $dump) {
+ $ok = 1;
+ } else {
+ kill SIGHUP => $pid;
+ }
+ }
+ }
+ return ($ok) ? $speed : 0;
+}
+
+sub bench {
+ 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 $dump = Dumper($msg);
+ 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;
+ $snd->post($msg);
+ $snd->speed($speed);
+ $snd->send($pid);
+ $r = <$rdr>;
+ alarm 0;
+ };
+ if (!defined $r) { # Something bad happened, respawn
+ slaughter;
+ spawn;
+ last TRY;
+ } else {
+ 1 while chomp $r;
+ if ($r eq $dump) {
+ ++$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