1 package IPC::MorseSignals;
9 use POSIX qw/SIGUSR1 SIGUSR2/;
10 use Time::HiRes qw/usleep/;
12 use constant PID_BITS => 24;
16 IPC::MorseSignals - Communicate between processes with Morse signals.
24 our $VERSION = '0.07';
28 use IPC::MorseSignals qw/msend mrecv/;
32 die "fork() failed: $!";
34 my $s = mrecv local %SIG, cb => sub {
35 print STDERR "received $_[1] from $_[0]!\n";
40 msend "hello!\n" => $pid;
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.
47 But, seriously, use something else for your IPC. :)
53 msend $msg, $pid [, speed => $speed, utf8 => $utf8, sign => $sign ]
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.
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;
69 $opts{sign} = 1 unless defined $opts{sign};
70 my $delay = int(1_000_000 / $opts{speed});
73 ($opts{utf8} ? 1 : 0),
74 ($opts{sign} ? 1 : 0),
77 my $n = 2 ** PID_BITS;
78 push @head, ($$ & $n) ? 1 : 0 while ($n /= 2) >= 1;
86 my @bits = split //, unpack $tpl, $msg;
89 my ($c, $n, @l) = (2, 0, 0, 0, 0);
94 if ($n > $l[$c]) { $l[$c] = $n; }
99 if ($n > $l[$c]) { $l[$c] = $n; }
100 ($c, $n) = ($l[0] > $l[1]) ? (1, $l[1]) : (0, $l[0]); # Take the smallest
102 @bits = (($c) x $n, 1 - $c, @bits, 1 - $c, ($c) x $n);
105 my $sig = ($_ == 0) ? SIGUSR1 : SIGUSR2;
113 mrecv %SIG [, cb => $callback ]
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 :
117 my $rcv = mrecv local %SIG, cb => sub { ... };
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.
127 croak 'Optional arguments must be passed as key => value pairs' if @o % 2;
129 my $s = { cb => $opts{cb} };
132 my $sighandler = sub {
135 if ($s->{state} == 5) { # data
138 if ((substr $s->{bits}, - $s->{n}) eq $s->{end}) {
139 substr $s->{bits}, - $s->{n}, $s->{n}, '';
141 $tpl = 'U0' . $tpl if $s->{utf8};
142 $s->{msg} = pack $tpl, $s->{bits};
144 $s->{cb}->(@{$s}{qw/sender msg/}) if $s->{cb};
147 } elsif ($s->{state} == 4) { # sender signature
149 if (length $s->{bits} < PID_BITS) {
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);
158 } elsif ($s->{state} == 3) { # signature flag
160 @{$s}{qw/state sign/} = ($b ? 4 : 5, $b);
162 } elsif ($s->{state} == 2) { # utf8 flag
164 @{$s}{qw/state utf8/} = (3, $b);
166 } elsif ($s->{state} == 1) { # end of signature
169 @{$s}{qw/state end/} = (2, (1 - $s->{c}) . $s->{c} x $s->{n});
175 @{$s}{qw/state c n sender msg/} = (1, $b, 1, 0, '');
181 @{$sig}{qw/USR1 USR2/} = (sub { $sighandler->(0) }, sub { $sighandler->(1) });
190 Resets the state of the receiver C<$rcv>. Useful to abort transfers.
196 croak 'Invalid receiver' unless defined $rcv;
197 @{$rcv}{qw/state c n bits end utf8 sign/} = (0, undef, 0, '', '', 0, 0);
204 Returns true if the receiver C<$rcv> is currently busy with incoming data, or false otherwise.
210 croak 'Invalid receiver' unless defined $rcv;
211 return $rcv->{state} > 0;
214 =head2 C<mlastsender>
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>.
224 croak 'Invalid receiver' unless defined $rcv;
225 return $rcv->{sender};
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>.
238 croak 'Invalid receiver' unless defined $rcv;
244 This module exports any of its functions only on request.
248 use base qw/Exporter/;
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;
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.
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.
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 :
265 =item - If m > n, we take n+1 times 1 follewed by one 0 ;
267 =item - Otherwise, we take m+1 times 0 follewed by one 1.
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).
273 a ... a b | u s [ p23 ... p0 ] | ... data ... | b a ... a
274 signature | header | data | reversed signature
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.
280 This type of IPC is highly unreliable. Send little data at slow speed if you want it to reach its goal.
282 C<SIGUSR{1,2}> seem to interrupt sleep, so it's not a good idea to transfer data to a sleeping process.
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.
290 L<perlipc> for information about signals in perl.
292 For truly useful IPC, search for shared memory, pipes and semaphores.
296 Vincent Pit, C<< <perl at profvince.com> >>
298 You can contact me by mail or on #perl @ FreeNode (Prof_Vince).
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.
310 You can find documentation for this module with the perldoc command.
312 perldoc IPC::MorseSignals
314 =head1 ACKNOWLEDGEMENTS
316 Thanks for the inspiration, mofino ! I hope this module will fill all your IPC needs. :)
318 =head1 COPYRIGHT & LICENSE
320 Copyright 2007 Vincent Pit, all rights reserved.
322 This program is free software; you can redistribute it and/or modify it
323 under the same terms as Perl itself.
327 1; # End of IPC::MorseSignals