From: Vincent Pit Date: Sun, 29 Jun 2008 16:36:54 +0000 (+0200) Subject: Importing IPC-MorseSignals-0.10.tar.gz X-Git-Tag: v0.11~1 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=ddcc7c395d570f0ea20a8e9a242fcbfcc0e49522;p=perl%2Fmodules%2FIPC-MorseSignals.git Importing IPC-MorseSignals-0.10.tar.gz --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..383375b --- /dev/null +++ b/Changes @@ -0,0 +1,70 @@ +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 : 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. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..c20c85d --- /dev/null +++ b/MANIFEST @@ -0,0 +1,28 @@ +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) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..3b5779a --- /dev/null +++ b/META.yml @@ -0,0 +1,25 @@ +--- #YAML:1.0 +name: IPC-MorseSignals +version: 0.10 +abstract: Communicate between processes with Morse signals. +license: perl +author: + - Vincent Pit +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 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..341a6ca --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,62 @@ +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 ', + 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-*' }, +); diff --git a/README b/README new file mode 100644 index 0000000..aa1abb9 --- /dev/null +++ b/README @@ -0,0 +1,79 @@ +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, "", . + + 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 + . 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. + diff --git a/lib/IPC/MorseSignals.pm b/lib/IPC/MorseSignals.pm new file mode 100644 index 0000000..8389e5a --- /dev/null +++ b/lib/IPC/MorseSignals.pm @@ -0,0 +1,96 @@ +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 and C. 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 is a base class for emitters ; + +=item L is a base class for receivers ; + +=back + +But, seriously, use something else for your IPC. :) + +=head1 DEPENDENCIES + +You need the complete L distribution. + +L (standard since perl 5), L (idem) and L (since perl 5.7.3) are also required. + +=head1 SEE ALSO + +L, L. + +L, L, L. + +L for information about signals in perl. + +For truly useful IPC, search for shared memory, pipes and semaphores. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +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, or through the web interface at L. 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 diff --git a/lib/IPC/MorseSignals/Emitter.pm b/lib/IPC/MorseSignals/Emitter.pm new file mode 100644 index 0000000..99fa22f --- /dev/null +++ b/lib/IPC/MorseSignals/Emitter.pm @@ -0,0 +1,165 @@ +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 emitter to another process as C (for bits 0) and C (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 specifies the delay between two sends, in seconds, while C is the number of bits sent per second. The delay value has priority over the speed. Extra arguments are passed to L. + +=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 + +Sends messages enqueued with L 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. + +=head1 EXPORT + +An object module shouldn't export any function, and so does this one. + +=head1 DEPENDENCIES + +L. + +L (standard since perl 5), L (idem) and L (since perl 5.7.3) are required. + +=head1 SEE ALSO + +L, L. + +L, L, L. + +L for information about signals in perl. + +For truly useful IPC, search for shared memory, pipes and semaphores. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +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, or through the web interface at L. 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 diff --git a/lib/IPC/MorseSignals/Receiver.pm b/lib/IPC/MorseSignals/Receiver.pm new file mode 100644 index 0000000..4ca5c10 --- /dev/null +++ b/lib/IPC/MorseSignals/Receiver.pm @@ -0,0 +1,104 @@ +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 receiver. + +=head1 METHODS + +=head2 C + +Creates a new receiver object. Its arguments are passed to L, in particular the C 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. + +=head1 EXPORT + +An object module shouldn't export any function, and so does this one. + +=head1 DEPENDENCIES + +L. + +L (standard since perl 5) is also required. + +=head1 SEE ALSO + +L, L. + +L, L, L. + +L for information about signals in perl. + +For truly useful IPC, search for shared memory, pipes and semaphores. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +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, or through the web interface at L. 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 diff --git a/samples/bench.pl b/samples/bench.pl new file mode 100755 index 0000000..2f7daae --- /dev/null +++ b/samples/bench.pl @@ -0,0 +1,36 @@ +#!/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; diff --git a/samples/try.pl b/samples/try.pl new file mode 100755 index 0000000..68388c8 --- /dev/null +++ b/samples/try.pl @@ -0,0 +1,32 @@ +#!/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; diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..a1bc3b7 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,14 @@ +#!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" ); diff --git a/t/02-can.t b/t/02-can.t new file mode 100644 index 0000000..a78573e --- /dev/null +++ b/t/02-can.t @@ -0,0 +1,19 @@ +#!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 ' . $_); +} + diff --git a/t/10-sigusr.t b/t/10-sigusr.t new file mode 100644 index 0000000..bfe2dc2 --- /dev/null +++ b/t/10-sigusr.t @@ -0,0 +1,19 @@ +#!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'); diff --git a/t/20-emitter-obj.t b/t/20-emitter-obj.t new file mode 100644 index 0000000..97204fe --- /dev/null +++ b/t/20-emitter-obj.t @@ -0,0 +1,51 @@ +#!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'); diff --git a/t/30-receiver-obj.t b/t/30-receiver-obj.t new file mode 100644 index 0000000..a2e4f19 --- /dev/null +++ b/t/30-receiver-obj.t @@ -0,0 +1,18 @@ +#!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"); diff --git a/t/50-self-plain.t b/t/50-self-plain.t new file mode 100644 index 0000000..d503113 --- /dev/null +++ b/t/50-self-plain.t @@ -0,0 +1,26 @@ +#!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; diff --git a/t/51-self-utf8.t b/t/51-self-utf8.t new file mode 100644 index 0000000..1b69273 --- /dev/null +++ b/t/51-self-utf8.t @@ -0,0 +1,29 @@ +#!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; diff --git a/t/52-self-storable.t b/t/52-self-storable.t new file mode 100644 index 0000000..6f3933c --- /dev/null +++ b/t/52-self-storable.t @@ -0,0 +1,34 @@ +#!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; diff --git a/t/60-fork-plain.t b/t/60-fork-plain.t new file mode 100644 index 0000000..54b73a7 --- /dev/null +++ b/t/60-fork-plain.t @@ -0,0 +1,25 @@ +#!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; + diff --git a/t/61-fork-utf8.t b/t/61-fork-utf8.t new file mode 100644 index 0000000..8ad2011 --- /dev/null +++ b/t/61-fork-utf8.t @@ -0,0 +1,26 @@ +#!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; + diff --git a/t/62-fork-storable.t b/t/62-fork-storable.t new file mode 100644 index 0000000..aeab377 --- /dev/null +++ b/t/62-fork-storable.t @@ -0,0 +1,32 @@ +#!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; + diff --git a/t/70-speed.t b/t/70-speed.t new file mode 100644 index 0000000..fc6f031 --- /dev/null +++ b/t/70-speed.t @@ -0,0 +1,29 @@ +#!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; diff --git a/t/90-boilerplate.t b/t/90-boilerplate.t new file mode 100644 index 0000000..ad8c282 --- /dev/null +++ b/t/90-boilerplate.t @@ -0,0 +1,51 @@ +#!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'); diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..62d2d7f --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,13 @@ +#!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(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..13665e8 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,23 @@ +#!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/^_/ ] +); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!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(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..2bf8079 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,11 @@ +#!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 $@; diff --git a/t/lib/IPC/MorseSignals/TestSuite.pm b/t/lib/IPC/MorseSignals/TestSuite.pm new file mode 100644 index 0000000..e11025b --- /dev/null +++ b/t/lib/IPC/MorseSignals/TestSuite.pm @@ -0,0 +1,162 @@ +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;