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.06
  21
  22 =cut
  23
  24 our $VERSION = '0.06';
  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 $rv = 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  @{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0);
 197 }
 198
 199 =head2 C<mbusy>
 200
 201     mbusy $rcv
 202
 203 Returns true if the receiver C<$rcv> is currently busy with incoming data, or false otherwise.
 204
 205 =cut
 206
 207 sub mbusy {
 208  my ($rcv) = @_;
 209  return $rcv->{state} > 0;
 210 }
 211
 212 =head2 C<mlastsender>
 213
 214     mlastmsg $rcv
 215
 216 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>.
 217
 218 =cut
 219
 220 sub mlastsender {
 221  my ($rcv) = @_;
 222  return $rcv->{sender};
 223 }
 224
 225 =head2 C<mlastmsg>
 226
 227     mlastmsg $rcv
 228
 229 Holds the last message received by C<$rcv>, or C<undef> if no message has arrived yet. It isn't cleared by L</mreset>.
 230
 231 =cut
 232
 233 sub mlastmsg {
 234  my ($rcv) = @_;
 235  return $rcv->{msg};
 236 }
 237
 238 =head1 EXPORT
 239
 240 This module exports any of its functions only on request.
 241
 242 =cut
 243
 244 use base qw/Exporter/;
 245
 246 our @EXPORT         = ();
 247 our %EXPORT_TAGS    = ( 'funcs' => [ qw/msend mrecv mreset mbusy mlastsender mlastmsg/ ] );
 248 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 249 $EXPORT_TAGS{'all'} = \@EXPORT_OK;
 250
 251 =head1 PROTOCOL
 252
 253 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.
 254
 255 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.
 256
 257 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 :
 258
 259 =over 4
 260
 261 =item - If m > n, we take n+1 times 1 follewed by one 0 ;
 262
 263 =item - Otherwise, we take m+1 times 0 follewed by one 1.
 264
 265 =back
 266
 267 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).
 268
 269     a ... a b | u s [ p23 ... p0 ] | ... data ... | b a ... a
 270     signature |      header        |     data     | reversed signature
 271
 272 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.
 273
 274 =head1 CAVEATS
 275
 276 This type of IPC is highly unreliable. Send little data at slow speed if you want it to reach its goal.
 277
 278 C<SIGUSR{1,2}> seem to interrupt sleep, so it's not a good idea to transfer data to a sleeping process.
 279
 280 =head1 DEPENDENCIES
 281
 282 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.
 283
 284 =head1 SEE ALSO
 285
 286 L<perlipc> for information about signals in perl.
 287
 288 For truly useful IPC, search for shared memory, pipes and semaphores.
 289
 290 =head1 AUTHOR
 291
 292 Vincent Pit, C<< <perl at profvince.com> >>
 293
 294 You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
 295
 296 =head1 BUGS
 297
 298 Please report any bugs or feature requests to
 299 C<bug-ipc-morsesignals at rt.cpan.org>, or through the web interface at
 300 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>.
 301 I will be notified, and then you'll automatically be notified of progress on
 302 your bug as I make changes.
 303
 304 =head1 SUPPORT
 305
 306 You can find documentation for this module with the perldoc command.
 307
 308     perldoc IPC::MorseSignals
 309
 310 =head1 ACKNOWLEDGEMENTS
 311
 312 Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
 313
 314 =head1 COPYRIGHT & LICENSE
 315
 316 Copyright 2007 Vincent Pit, all rights reserved.
 317
 318 This program is free software; you can redistribute it and/or modify it
 319 under the same terms as Perl itself.
 320
 321 =cut
 322
 323 1; # End of IPC::MorseSignals