lib/IPC/MorseSignals.pm

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