lib/IPC/MorseSignals.pm

   1 package IPC::MorseSignals;
   2
   3 use strict;
   4 use warnings;
   5
   6 use utf8;
   7
   8 use Carp qw/croak/;
   9 use POSIX qw/SIGUSR1 SIGUSR2/;
  10 use Time::HiRes qw/usleep/;
  11
  12 =head1 NAME
  13
  14 IPC::MorseSignals - Communicate between processes with Morse signals.
  15
  16 =head1 VERSION
  17
  18 Version 0.05
  19
  20 =cut
  21
  22 our $VERSION = '0.05';
  23
  24 =head1 SYNOPSIS
  25
  26     use IPC::MorseSignals qw/msend mrecv/;
  27
  28     my $pid = fork;
  29     if (!defined $pid) {
  30      die "fork() failed: $!";
  31     } elsif ($pid == 0) {
  32      local @SIG{qw/USR1 USR2/} = mrecv sub {
  33       print STDERR "received $_[0]!\n";
  34       exit
  35      };
  36      1 while 1;
  37     }
  38     msend "hello!\n" => $pid;
  39     waitpid $pid, 0;
  40
  41 =head1 DESCRIPTION
  42
  43 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.
  44
  45 But, seriously, use something else for your IPC. :)
  46
  47 =head1 FUNCTIONS
  48
  49 =head2 C<msend>
  50
  51     msend $msg, $pid [, speed => $speed, utf8 => $utf8 ]
  52
  53 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.
  54 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.
  55
  56 =cut
  57
  58 sub msend {
  59  my ($msg, $pid, @o) = @_;
  60  my @pid = (ref $pid eq 'ARRAY') ? @$pid : $pid;
  61  return unless defined $msg && length $msg;
  62  croak 'No PID was supplied' unless @pid;
  63  croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
  64  my %opts = @o;
  65  $opts{speed} ||= 512;
  66  $opts{utf8}  ||= 0;
  67  my $delay = int(1_000_000 / $opts{speed});
  68  my $tpl = 'B*';
  69  if ($opts{utf8}) {
  70   utf8::encode $msg;
  71   $tpl = 'U0' . $tpl;
  72  }
  73  my @bits = split //, unpack $tpl, $msg;
  74  my ($c, $n, @l) = (2, 0, 0, 0, 0);
  75  for (@bits) {
  76   if ($c == $_) {
  77    ++$n;
  78   } else {
  79    if ($n > $l[$c]) { $l[$c] = $n; }
  80    $n = 1;
  81    $c = $_;
  82   }
  83  }
  84  if ($n > $l[$c]) { $l[$c] = $n; }
  85  ($c, $n) = ($l[0] > $l[1]) ? (1, $l[1]) : (0, $l[0]); # Take the smallest
  86  ++$n;
  87  @bits = (($c) x $n, 1 - $c, @bits, 1 - $c, ($c) x $n);
  88  for (@bits) {
  89   my $sig = ($_ == 0) ? SIGUSR1 : SIGUSR2;
  90   usleep $delay;
  91   kill $sig, @pid;
  92  }
  93 }
  94
  95 =head2 C<mrecv>
  96
  97     mrecv $callback [, utf => $utf8 ]
  98
  99 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 :
 100
 101     local @SIG{qw/USR1 USR2/} = mrecv sub { ... };
 102
 103 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.
 104
 105 =cut
 106
 107 sub mrecv {
 108  my ($cb, @o) = @_;
 109  croak 'No callback was specified' unless $cb;
 110  croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
 111  my %opts = @o;
 112  $opts{utf8} ||= 0;
 113  my ($bits, $state, $c, $n, $end) = ('', 0, undef, 0, '');
 114  my $sighandler = sub {
 115   my ($b) = @_;
 116   if ($state == 2) {
 117    if (defined $bits && (substr $bits, -$n) eq $end) { # done
 118     substr $bits, -$n, $n, '';
 119     my $tpl = 'B*';
 120     $tpl = 'U0' . $tpl if $opts{utf8};
 121     my $msg = pack $tpl, $bits;
 122     $cb->($msg);
 123    }
 124   } elsif ($state == 1) {
 125    if ($c != $b) {
 126     $state = 2;
 127     $end = (1 - $c) . $c x $n;
 128     $bits = '';
 129    }
 130    ++$n;
 131   } else {
 132    $c = $b;
 133    $n = 1;
 134    $state = 1;
 135   }
 136  };
 137  return sub {
 138   $bits .= 0;
 139   $sighandler->(0);
 140  }, sub {
 141   $bits .= 1;
 142   $sighandler->(1);
 143  };
 144 }
 145
 146 =head1 EXPORT
 147
 148 This module exports on request its two only functions, L</msend> and L</mrecv>.
 149
 150 =cut
 151
 152 use base qw/Exporter/;
 153
 154 our @EXPORT         = ();
 155 our %EXPORT_TAGS    = ( 'funcs' => [ qw/msend mrecv/ ] );
 156 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 157 $EXPORT_TAGS{'all'} = \@EXPORT_OK;
 158
 159 =head1 PROTOCOL
 160
 161 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 :
 162
 163 =over 4
 164
 165 =item - If m > n, we take n+1 times 1 follewed by one 0 ;
 166
 167 =item - Otherwise, we take m+1 times 0 follewed by one 1.
 168
 169 =back
 170
 171 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).
 172
 173 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.
 174
 175 =head1 CAVEATS
 176
 177 This type of IPC is highly unreliable. Send little data at slow speed if you want it to reach its goal.
 178
 179 C<SIGUSR{1,2}> seem to interrupt sleep, so it's not a good idea to transfer data to a sleeping process.
 180
 181 =head1 DEPENDENCIES
 182
 183 L<Carp> (standard since perl 5), L<POSIX> (idem), L<Time::HiRes> (since perl 5.7.3) and L<utf8> (since perl 5.6) are required.
 184
 185 =head1 SEE ALSO
 186
 187 L<perlipc> for information about signals in perl.
 188
 189 For truly useful IPC, search for shared memory, pipes and semaphores.
 190
 191 =head1 AUTHOR
 192
 193 Vincent Pit, C<< <perl at profvince.com> >>
 194
 195 You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
 196
 197 =head1 BUGS
 198
 199 Please report any bugs or feature requests to
 200 C<bug-ipc-morsesignals at rt.cpan.org>, or through the web interface at
 201 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>.
 202 I will be notified, and then you'll automatically be notified of progress on
 203 your bug as I make changes.
 204
 205 =head1 SUPPORT
 206
 207 You can find documentation for this module with the perldoc command.
 208
 209     perldoc IPC::MorseSignals
 210
 211 =head1 ACKNOWLEDGEMENTS
 212
 213 Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
 214
 215 =head1 COPYRIGHT & LICENSE
 216
 217 Copyright 2007 Vincent Pit, all rights reserved.
 218
 219 This program is free software; you can redistribute it and/or modify it
 220 under the same terms as Perl itself.
 221
 222 =cut
 223
 224 1; # End of IPC::MorseSignals