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 use constant PID_BITS => 24;
  13
  14 =head1 NAME
  15
  16 IPC::MorseSignals - Communicate between processes with Morse signals.
  17
  18 =head1 VERSION
  19
  20 Version 0.07
  21
  22 =cut
  23
  24 our $VERSION = '0.07';
  25
  26 =head1 SYNOPSIS
  27
  28     use IPC::MorseSignals qw/msend mrecv/;
  29
  30     my $pid = fork;
  31     if (!defined $pid) {
  32      die "fork() failed: $!";
  33     } elsif ($pid == 0) {
  34      my $s = mrecv local %SIG, cb => sub {
  35       print STDERR "received $_[1] from $_[0]!\n";
  36       exit
  37      };
  38      1 while 1;
  39     }
  40     msend "hello!\n" => $pid;
  41     waitpid $pid, 0;
  42
  43 =head1 DESCRIPTION
  44
  45 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.
  46
  47 But, seriously, use something else for your IPC. :)
  48
  49 =head1 FUNCTIONS
  50
  51 =head2 C<msend>
  52
  53     msend $msg, $pid [, speed => $speed, utf8 => $utf8, sign => $sign ]
  54
  55 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.
  56 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.
  57
  58 =cut
  59
  60 sub msend {
  61  my ($msg, $pid, @o) = @_;
  62  my @pids = (ref $pid eq 'ARRAY') ? @$pid : $pid;
  63  return unless defined $msg && length $msg;
  64  croak 'No PID was supplied' unless @pids;
  65  croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
  66  my %opts = @o;
  67  $opts{speed} ||= 512;
  68  $opts{utf8}  ||= 0;
  69  $opts{sign}    = 1 unless defined $opts{sign};
  70  my $delay = int(1_000_000 / $opts{speed});
  71
  72  my @head = (
  73   ($opts{utf8} ? 1 : 0),
  74   ($opts{sign} ? 1 : 0),
  75  );
  76  if ($opts{sign}) {
  77   my $n = 2 ** PID_BITS;
  78   push @head, ($$ & $n) ? 1 : 0 while ($n /= 2) >= 1;
  79  }
  80
  81  my $tpl = 'B*';
  82  if ($opts{utf8}) {
  83   utf8::encode $msg;
  84   $tpl = 'U0' . $tpl;
  85  }
  86  my @bits = split //, unpack $tpl, $msg;
  87
  88  unshift @bits, @head;
  89  my ($c, $n, @l) = (2, 0, 0, 0, 0);
  90  for (@bits) {
  91   if ($c == $_) {
  92    ++$n;
  93   } else {
  94    if ($n > $l[$c]) { $l[$c] = $n; }
  95    $n = 1;
  96    $c = $_;
  97   }
  98  }
  99  if ($n > $l[$c]) { $l[$c] = $n; }
 100  ($c, $n) = ($l[0] > $l[1]) ? (1, $l[1]) : (0, $l[0]); # Take the smallest
 101  ++$n;
 102  @bits = (($c) x $n, 1 - $c, @bits, 1 - $c, ($c) x $n);
 103
 104  for (@bits) {
 105   my $sig = ($_ == 0) ? SIGUSR1 : SIGUSR2;
 106   usleep $delay;
 107   kill $sig => @pids;
 108  }
 109 }
 110
 111 =head2 C<mrecv>
 112
 113     mrecv %SIG [, cb => $callback ]
 114
 115 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 :
 116
 117     my $rcv = mrecv local %SIG, cb => sub { ... };
 118
 119 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.
 120
 121 =cut
 122
 123 sub mreset;
 124
 125 sub mrecv (\%@) {
 126  my ($sig, @o) = @_;
 127  croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
 128  my %opts = @o;
 129  my $s = { cb => $opts{cb} };
 130  mreset $s;
 131
 132  my $sighandler = sub {
 133   my ($b) = @_;
 134
 135   if ($s->{state} == 5) { # data
 136
 137    $s->{bits} .= $b;
 138    if ((substr $s->{bits}, - $s->{n}) eq $s->{end}) {
 139     substr $s->{bits}, - $s->{n}, $s->{n}, '';
 140     my $tpl = 'B*';
 141     $tpl = 'U0' . $tpl if $s->{utf8};
 142     $s->{msg} = pack $tpl, $s->{bits};
 143     mreset $s;
 144     $s->{cb}->(@{$s}{qw/sender msg/}) if $s->{cb};
 145    }
 146
 147   } elsif ($s->{state} == 4) { # sender signature
 148
 149    if (length $s->{bits} < PID_BITS) {
 150     $s->{bits} .= $b;
 151    } else {
 152     my $n = 2 ** PID_BITS;
 153     my @b = split //, $s->{bits};
 154     $s->{sender} += $n * shift @b while ($n /= 2) >= 1;
 155     @{$s}{qw/state bits/} = (5, $b);
 156    }
 157
 158   } elsif ($s->{state} == 3) { # signature flag
 159
 160    @{$s}{qw/state sign/} = ($b ? 4 : 5, $b);
 161
 162   } elsif ($s->{state} == 2) { # utf8 flag
 163
 164    @{$s}{qw/state utf8/} = (3, $b);
 165
 166   } elsif ($s->{state} == 1) { # end of signature
 167
 168    if ($s->{c} != $b) {
 169     @{$s}{qw/state end/} = (2, (1 - $s->{c}) . $s->{c} x $s->{n});
 170    }
 171    ++$s->{n};
 172
 173   } else { # first bit
 174
 175    @{$s}{qw/state c n sender msg/} = (1, $b, 1, 0, '');
 176
 177   }
 178
 179  };
 180
 181  @{$sig}{qw/USR1 USR2/} = (sub { $sighandler->(0) }, sub { $sighandler->(1) });
 182
 183  return $s;
 184 }
 185
 186 =head2 C<mreset>
 187
 188     mreset $rcv
 189
 190 Resets the state of the receiver C<$rcv>. Useful to abort transfers.
 191
 192 =cut
 193
 194 sub mreset {
 195  my ($rcv) = @_;
 196  croak 'Invalid receiver' unless defined $rcv;
 197  @{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0);
 198 }
 199
 200 =head2 C<mbusy>
 201
 202     mbusy $rcv
 203
 204 Returns true if the receiver C<$rcv> is currently busy with incoming data, or false otherwise.
 205
 206 =cut
 207
 208 sub mbusy {
 209  my ($rcv) = @_;
 210  croak 'Invalid receiver' unless defined $rcv;
 211  return $rcv->{state} > 0;
 212 }
 213
 214 =head2 C<mlastsender>
 215
 216     mlastsender $rcv
 217
 218 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>.
 219
 220 =cut
 221
 222 sub mlastsender {
 223  my ($rcv) = @_;
 224  croak 'Invalid receiver' unless defined $rcv;
 225  return $rcv->{sender};
 226 }
 227
 228 =head2 C<mlastmsg>
 229
 230     mlastmsg $rcv
 231
 232 Holds the last message received by C<$rcv>, or C<undef> if no message has arrived yet. It isn't cleared by L</mreset>.
 233
 234 =cut
 235
 236 sub mlastmsg {
 237  my ($rcv) = @_;
 238  croak 'Invalid receiver' unless defined $rcv;
 239  return $rcv->{msg};
 240 }
 241
 242 =head1 EXPORT
 243
 244 This module exports any of its functions only on request.
 245
 246 =cut
 247
 248 use base qw/Exporter/;
 249
 250 our @EXPORT         = ();
 251 our %EXPORT_TAGS    = ( 'funcs' => [ qw/msend mrecv mreset mbusy mlastsender mlastmsg/ ] );
 252 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 253 $EXPORT_TAGS{'all'} = \@EXPORT_OK;
 254
 255 =head1 PROTOCOL
 256
 257 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.
 258
 259 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.
 260
 261 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 :
 262
 263 =over 4
 264
 265 =item - If m > n, we take n+1 times 1 follewed by one 0 ;
 266
 267 =item - Otherwise, we take m+1 times 0 follewed by one 1.
 268
 269 =back
 270
 271 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).
 272
 273     a ... a b | u s [ p23 ... p0 ] | ... data ... | b a ... a
 274     signature |      header        |     data     | reversed signature
 275
 276 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.
 277
 278 =head1 CAVEATS
 279
 280 This type of IPC is highly unreliable. Send little data at slow speed if you want it to reach its goal.
 281
 282 C<SIGUSR{1,2}> seem to interrupt sleep, so it's not a good idea to transfer data to a sleeping process.
 283
 284 =head1 DEPENDENCIES
 285
 286 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.
 287
 288 =head1 SEE ALSO
 289
 290 L<perlipc> for information about signals in perl.
 291
 292 For truly useful IPC, search for shared memory, pipes and semaphores.
 293
 294 =head1 AUTHOR
 295
 296 Vincent Pit, C<< <perl at profvince.com> >>
 297
 298 You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
 299
 300 =head1 BUGS
 301
 302 Please report any bugs or feature requests to
 303 C<bug-ipc-morsesignals at rt.cpan.org>, or through the web interface at
 304 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>.
 305 I will be notified, and then you'll automatically be notified of progress on
 306 your bug as I make changes.
 307
 308 =head1 SUPPORT
 309
 310 You can find documentation for this module with the perldoc command.
 311
 312     perldoc IPC::MorseSignals
 313
 314 =head1 ACKNOWLEDGEMENTS
 315
 316 Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
 317
 318 =head1 COPYRIGHT & LICENSE
 319
 320 Copyright 2007 Vincent Pit, all rights reserved.
 321
 322 This program is free software; you can redistribute it and/or modify it
 323 under the same terms as Perl itself.
 324
 325 =cut
 326
 327 1; # End of IPC::MorseSignals