lib/IPC/MorseSignals.pm

   1 package IPC::MorseSignals;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Time::HiRes qw/usleep/;
   7 use POSIX qw/SIGUSR1 SIGUSR2/;
   8
   9 =head1 NAME
  10
  11 IPC::MorseSignals - Communicate between processes with Morse signals.
  12
  13 =head1 VERSION
  14
  15 Version 0.01
  16
  17 =cut
  18
  19 our $VERSION = '0.01';
  20
  21 =head1 SYNOPSIS
  22
  23     use IPC::MorseSignals qw/msend mrecv/;
  24
  25     my $pid = fork;
  26     if (!defined $pid) {
  27      die "fork() failed: $!";
  28     } elsif ($pid == 0) {
  29      local @SIG{qw/USR1 USR2/} = mrecv sub { print STDERR "recieved $_[0]!\n" };
  30      1 while 1;
  31     }
  32     msend "hello!\n" => $pid;
  33     waitpid $pid, 0;
  34
  35 =head1 DESCRIPTION
  36
  37 This module implements a rare form of IPC by sending Morse-like signals through C<SIGUSR1> and C<SIGUSR2>. It uses both signals C<SIGUSR1> and C<SIGUSR2>, so you won't be able to keep them for something else when you use this module.
  38
  39 But, seriously, use something else for your IPC. :)
  40
  41 =head1 FUNCTIONS
  42
  43 =head2 C<msend>
  44
  45     msend $msg, $pid [, $speed ]
  46
  47 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. Default speed is 1000, don't set it too low or the target will miss bits and the whole message will be crippled.
  48
  49 =cut
  50
  51 sub msend {
  52  my ($msg, $pid, $speed) = @_;
  53  my @pid = (ref $pid eq 'ARRAY') ? @$pid : $pid;
  54  return unless @pid && $msg;
  55  $speed ||= 1000;
  56  my $delay = int(1_000_000 / $speed);
  57  my @bits = split //, unpack 'B*', $msg;
  58  my ($c, $n, @l) = (2, 0, 0, 0, 0);
  59  for (@bits) {
  60   if ($c == $_) {
  61    ++$n;
  62   } else {
  63    if ($n > $l[$c]) { $l[$c] = $n; }
  64    $n = 1;
  65    $c = $_;
  66   }
  67  }
  68  if ($n > $l[$c]) { $l[$c] = $n; }
  69  ($c, $n) = ($l[0] > $l[1]) ? (1, $l[1]) : (0, $l[0]); # Take the smallest
  70  ++$n;
  71  @bits = (($c) x $n, 1 - $c, @bits, 1 - $c, ($c) x $n);
  72  for (@bits) {
  73   my $sig = ($_ == 0) ? SIGUSR1 : SIGUSR2;
  74   usleep $delay;
  75   kill $sig, @pid;
  76  }
  77 }
  78
  79 =head2 C<mrecv>
  80
  81     mrecv $callback
  82
  83 Takes as its sole 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 :
  84
  85     local @SIG{qw/USR1 USR2/} = mrecv sub { ... };
  86
  87 =cut
  88
  89 sub mrecv {
  90  my ($cb) = @_;
  91  my ($bits, $state, $c, $n, $end) = ('', 0, undef, 0, undef);
  92  my $sighandler = sub {
  93   my ($b) = @_;
  94   if ($state == 2) {
  95    if ((substr $bits, -$n) eq $end) { # done
  96     substr $bits, -$n, $n, '';
  97     $cb->(pack 'B*', $bits);
  98    }
  99   } elsif ($state == 1) {
 100    if ($c != $b) {
 101     $state = 2;
 102     $end = (1 - $c) . $c x $n;
 103     $bits = '';
 104    }
 105    ++$n;
 106   } else {
 107    $c = $b;
 108    $n = 1;
 109    $state = 1;
 110   }
 111  };
 112  return sub {
 113   $bits .= 0;
 114   $sighandler->(0);
 115  }, sub {
 116   $bits .= 1;
 117   $sighandler->(1);
 118  };
 119 }
 120
 121 =head1 EXPORT
 122
 123 This module exports on request its two only functions, L</msend> and L</mrecv>.
 124
 125 =cut
 126
 127 use base qw/Exporter/;
 128
 129 our @EXPORT         = ();
 130 our %EXPORT_TAGS    = ( 'funcs' => [ qw/msend mrecv/ ] );
 131 our @EXPORT_OK      = map { @$_ } values %EXPORT_TAGS;
 132 $EXPORT_TAGS{'all'} = \@EXPORT_OK;
 133
 134 =head1 DEPENDENCIES
 135
 136 L<POSIX> (standard since perl 5) and L<Time::HiRes> (standard since perl 5.7.3) are required.
 137
 138 =head1 SEE ALSO
 139
 140 L<perlipc> for information about signals.
 141
 142 For truely useful IPC, search for shared memory, pipes and semaphores.
 143
 144 =head1 AUTHOR
 145
 146 Vincent Pit, C<< <perl at profvince.com> >>
 147
 148 You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
 149
 150 =head1 BUGS
 151
 152 Please report any bugs or feature requests to
 153 C<bug-ipc-morsesignals at rt.cpan.org>, or through the web interface at
 154 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>.
 155 I will be notified, and then you'll automatically be notified of progress on
 156 your bug as I make changes.
 157
 158 =head1 SUPPORT
 159
 160 You can find documentation for this module with the perldoc command.
 161
 162     perldoc IPC::MorseSignals
 163
 164 =head1 ACKNOWLEDGEMENTS
 165
 166 Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
 167
 168 =head1 COPYRIGHT & LICENSE
 169
 170 Copyright 2007 Vincent Pit, all rights reserved.
 171
 172 This program is free software; you can redistribute it and/or modify it
 173 under the same terms as Perl itself.
 174
 175 =cut
 176
 177 1; # End of IPC::MorseSignals