package ForkMe; #I don't think I could have resisted it, but I didn't
+ even try.
use strict;
use warnings;
use IO::Socket;
use IO::Select;
use Data::Dumper;
use POSIX ':sys_wait_h';
$SIG{PIPE} = 'IGNORE';
my %children;
=head1 Name
IPC::ForkMe
=head1 Synopsis
C<use ForkMe;
use strict;
use warnings;
use diagnostics;
>
C<my $fork = new ForkMe or die "Couldn't fork: $@\n";>
C<foreach ( 1..100 ) {
$fork-E<gt>send_message(join("", "This is the ", $fork-E<gt>{Whoami},
+" process
saying hello")) or die "Couldn't send message: $@\n"; >
C<my $temp = $fork-E<gt>read_message or warn "Couldn't read message: $
+@\n";>
C<print "This the the ", $fork-E<gt>{Whoami};>
C<print " process, and I just received a message. ";>
C<print "It reads:\n\"",$temp, "\"\n\n\n--------------\n";}>
=head1 Abstract
This perl library is designed to take all the pain out of forks and IP
+C. ForkMe does the fork for you, and also opens
up a I<TCP socket> connection with the child. It provides methods to
+communicate between the child and the parent.
=head1 Description
=head2 What it does
When you create a new instance with C<my $fork = new ForkMe> the modul
+e does the following:
=over 4
=item *
Opens a socket on an unpriviledged port
=item *
Forks
=item *
The child connects to the socket, the parent accepts
=item *
Both processes return an object ref if successful, or undef upon failu
+re. There may be a message in $@
=back
=head2 What it's useful for
A very quick and easy IPC. Not guaranteed to be fast, small or anythi
+ng else except convenient.
I just got sick of spending half and hour going through the IPC doco
+s (good as they are) trying to remember how to do
IPC. I mostly use it for providing a way for the program to be doing
+ something constantly while waiting for user input.
If you start doing multiple forks from both parents and children you
+ will almost certainly confuse this module. So for
now, don't get too carried away. See todo for an idea on how to safe
+ly manage
multiple forks.
Now there's no need to worry about how to read one character from the
+keyboard without blocking - just fire this
up:
C<my $fork = new ForkMe or die "Couldn't fork: $@\n";>
C<if ($fork-E<gt>{PARENT} ) {>
C<
while (1) {
$input = E<lt>STDINE<gt>;
$fork-E<gt>send_message($input);
}>
C< } else { >
C<while (1) {>
C< my @do_thing;>
C< if ( $fork->message_waiting ) {@do_thing = $fork-E<gt>read_mes
+sage;}>
#Do something with @do_thing here
}
of course you can have much more fun with L<Term::Readline>.
=head1 Object Methods
=over 4
=cut
BEGIN {
our ($VERSION);
# set the version for version checking
$VERSION = .06;
# if using RCS/CVS, this may be preferred
$VERSION = do { my @r = (q$Revision: 0.06 $ =~ /\d+/g); sprint
+f "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
}
sub DESTROY {
my $self = shift;
#Shutdown TCP/IP connections here
close $self->{SOCKET} if $self->{SOCKET};
if ( $self->{PARENT} && $self->{SLAY_CHILDREN} ) {
my $child_pid = $self->{CHILD_PID};
$self->_debug("Now destroying object for child ",$child_pi
+d);
$ForkMe::children{$child_pid} = undef;
kill 1, $child_pid;
#XXX Trouble here
sleep 1;
kill 9, $child_pid;
}
if ( $self->{CHILD} && $self->{SLAY_PARENTS} ) {
my $parent_pid = $self->{PARENT_PID};
print $self->_debug("Now destroying object ", $parent_pid)
+;
kill 1, $parent_pid;
#XXX Trouble here
sleep 1;
kill 9, $parent_pid;
}
}
sub REAPER {
my $stiff;
while(($stiff = waitpid(-1,WNOHANG))>0){
$ForkMe::children{$stiff} = undef;
print $$,": Now reaping child ", $stiff, "\n" if $Fork
+Me::children{$stiff}->{DEBUG};
}
$SIG{CHLD}=\&REAPER;
};
sub _debug {
my $self = shift;
my @msg = @_;
print $self->{Whoami}, " ", $$, ": ", @msg, "\n" if $self->{DEBUG
+};
}
=item new
C<$thing = new ForkMe("slay_children silent_children")>
All the action happens here. When called, it forks and sets up the IP
+C, as described above. There are some options
you can pass to it. All options are passed as one long string, sepa
+rated by spaces (yes, I'll be changing this
in the future).
=over 3
=item slay_children
When the parent quits, ForkMe will automatically kill the child (the o
+ther half
of the fork).
=item slay_children
As above, but when the child quits it will kill the parents
=item silent_children
Opens STDIN, STDOUT, STDERR to "/dev/null". The child process will no
+ longer be able to read or write
to or from the standard pipes. Great if you are using someone elses
+code that
is a little too chatty.
=item silent_parents
Same as for silent_children.
=item debug
Switch on debugging. You can do this at any time with C<$fork-E<gt>{D
+EBUG}=1;>
=back
=cut
sub new {
my $self = bless {}, ref($_[0]) || $_[0] || __PACKAGE__;
my $options = " ";
$options = $_[1];
$self->{MSG_QUEUE}=[];
$self->{CHARBUFFER}='';
$self->{SLAY_CHILDREN} = 1 if $options =~ /slay_childr
+en/i;
$self->{DEBUG} = 1 if $options =~ /debug/i;
#$self->{DEBUG} = 1;
$self->{SLAY_PARENTS} = 1 if $options =~ /slay_parent/
+i;
$self->{CHILDREN_NOT_SEEN_OR_HEARD} = 1 if $options =~
+ /silent_children/i;
$self->{PARENTS_NOT_SEEN_OR_HEARD} = 1 if $options =~
+/silent_parent/i;
return $self->forkme ? $self : undef;
}
sub forkme {
my $self = shift;
my $listen_sock;
#Take five shots at getting an available port
foreach ( 1..5 ) {
$self->{PORT} = int rand(65000) + 1001;
#$self->_debug( "Creating socket on port $self->{port}" );
$listen_sock = IO::Socket::INET->new(
LocalAddr => 'localhost',
LocalPort => $self->{PORT},
Proto => 'tcp',
#Type => SOCK_STREAM,
Listen => 5,
Reuse => 1);
$self->_debug( "Attempting to listen on",$self->{PORT}
+);
last if $listen_sock;
}
unless ( $listen_sock ) {$@ = "Parent was unable to establish
+listening
socket\n"; return undef;};
$listen_sock->timeout(5);
my $pid;
#getppid() doesn't work under windows, so we work around
#by remembering the ppid before we fork.
my $ppid = $$;
defined( $pid = fork ) or $self->_debug( "Can't fork: $!" ) an
+d return;
if ( $pid > 0 ) {
#We are the parent
$self->{PARENT} = 1; $self->{CHILD} = 0; $self->{WHOAM
+I} = "PARENT"; $self->{Whoami} = "Parent";
$self->{CHILD_PID} = $pid; $self->{PID} = $$; $self->
+{OTHER_PID} = $pid;
$self->_debug( "Successfully forked, I am the parent o
+f child ",$self->{CHILD_PID});
if ( $self->{SOCKET} = $listen_sock->accept() ) {
$self->{SOCKET}->autoflush(1);
$self->{SELECT} = IO::Select->new($self->{SOCK
+ET});
#I don't know of a way to tell the child if th
+e parent quits
#The parent will receive a SIGCHLD when the ch
+ild quits
$SIG{CHLD}=\&REAPER;
if ( $self->{PARENT} && $self->{PARENTS_NOT_SE
+EN_OR_HEARD} && !($^O =~ /windows/i) ) {
open STDIN, "</dev/null";
open STDOUT, ">/dev/null";
open STDERR, ">/dev/null";
}
$self->{ACTIVE} = 1;
$self->_debug("Now pushing ref to $pid into trackin
+g hash");
$ForkMe::children{$pid} = $self;
$self->_debug( "Accepted incoming connection and re
+turning control to main loop");
return 1;
}
$self->_debug("Forked succesfully, but the child failed to
+ connect");
$@ = "The fork was successful, but the parent failed to re
+ceive a connection from the child.\n";
return undef;
}
else {
#We are the child
sleep 1;
print "Successfully forked, I am the child ",
+$$, "\n" if $self->{DEBUG};
#die "Child successfully forked!\n";
#Setup some useful variables for the child
$self->{PARENT} = 0; $self->{CHILD} = 1; $self
+->{WHOAMI} = "CHILD"; $self->{Whoami} = "Child";
$self->{PARENT_PID}=$ppid; $self->{PID} = $$;
+$self->{OTHER_PID} = $ppid;
#We are no longer the parent for all these pro
+cesses
foreach my $pd (keys %ForkMe::children) {
print $self->{Whoami}, "$$: Now swatti
+ng refs to $pd\n" if $self->{DEBUG};
print $self->{Whoami}, "$$: which was
+put there
by ", $ForkMe::children{$pd}->{PID}, "\n" if $self->{DEBUG};
$ForkMe::children{$pd}->{PARENT} = und
+ef;
$ForkMe::children{$pd}->{CHILD} = unde
+f;
$ForkMe::children{$pd}->{WHOAMI} = "bl
+ah!"; #undef;
$ForkMe::children{$pd}->{Whoami} = "Bl
+ah!";
$ForkMe::children{$pd}->{CHILD_PID} =
+"blah!"; #undef;
$ForkMe::children{$pd}->{PID} = "blah!
+"; #undef; $ForkMe::children{$pd}->{AC
+TIVE} = undef;
print $self->{Whoami}, "$$: Finished s
+watting refs to $pd\n" if $self->{DEBUG};
}
delete @ForkMe::children{keys %ForkMe::childre
+n};
#Try and connect to the parent, who should be
+listening
on $port
my $connection = IO::Socket::INET->new(
Proto => "tcp",
PeerAddr => 'localhost',
PeerPort => $self->{PORT},
);
unless ( $connection) {$@ = "Child couldn't connect
+ to parent\n"; return undef;};
$self->_debug( "Successfully connected to parent\n"
+ );
$connection->autoflush(1);
$self->{SELECT} = IO::Select->new($connection);
$self->{SOCKET} = $connection;
#Shutdown STDIN, STDOUT and STDERR so the child doe
+sn't mess with the parents I/O. This works, but isn't portable.
if ( $self->{CHILD} && $self->{CHILDREN_NOT_SEEN_OR
+_HEARD} && !($^O =~ /windows/i) ) {
#print "\nNow gonna be quiet because silent_ch
+ildren = ", $self->{CHILDREN_NOT_SEEN_OR_HEARD};
open STDIN, "</dev/null";
open STDOUT, ">/dev/null";
open STDERR, ">/dev/null";
}
print "Child $$: Connected successfully and now re
+turning control to the main routine\n" if $self->{DEBUG};
$self->{ACTIVE}=1;
return 1;
}
}
=item read_message
C<($message, $more_message) = $fork-E<gt>read_message>
C<print $fork-E<gt>read_message>
Returns a list - the variables that you sent from the other half of th
+e fork using send_message. Effectively a message
is a list of variables and their contents.
Note that you can pass variables by reference and they will work fine.
=cut
sub read_message {
my $self = shift;
#Call _read_messages then return the first message in the
#queue, if any
$self->_read_messages;
my $msg = shift @{$self->{MSG_QUEUE}};
return unless defined $msg;
#$self->_debug( "got message from queue ", $msg );
my $values=undef;
eval $msg;
#die "Died on bad eval!!! $@ - eval text follows:\n $msg" if $
+@;
$values = undef if $@;
$values ||= []; #Or else we die below if $values is undef
return scalar @{$values} ? @{$values} : undef;
}
sub _read_messages {
#Do the select stuff and push any messages found onto the
#msg_queue
my $self = shift;
#my $connection=$self->{SOCKET};
#print "Checking ", $self->{SELECT}->count, " ready sockets to
+ read from in $$\n" if $self->{DEBUG};
my @ready = $self->{SELECT}->can_read(0);
#print "$$ has ", scalar(@ready), " sockets ready to read from
+\n" if $self->{DEBUG};
my @error = $self->{SELECT}->has_exception(0);
#print "$$ has ", scalar @error, " sockets in error condition\
+n" if $self->{DEBUG};
$self->_inactivate if @error ;
foreach my $connection (@ready) {
my $z;
recv $connection,$z,100000,0;
print $self->{WHOAMI}, ": Read ", length($z), " charac
+ters from
socket\n" if $self->{DEBUG};
$self->{CHARBUFFER}.= $z;
}
while ($self->{CHARBUFFER} =~ s/^([^\n]+\n)(.+?)(\1)//gs) {
#$self->_debug( " I think the message is ", $2) ;
my $message = unpack("u", $2);
#$message = unpack "u", $message;
#unless ( $message =~ /\$values / ) {$self->_debug("Buffer ove
+rflow!!!!
Need to decrease sampling time!!!!"); next;}
push @{$self->{MSG_QUEUE}}, $message if $message;
$self->_debug("Message queue: ", @{$self->{MSG_QUEUE}});
}
}
=item send_message
C<$fork-E<gt>send_message($message,"More message", "Even more mesage")
+>
Accepts a list and sends it. Returns true on success, undefined other
+wise. There may be an error message in $@.
I have tried this with lists and lists of hashes, both of which go thr
+ough fine. It relies on Data::Dumper to
bundle up your varibales and send them through. I still recommend aga
+inst trying anything really tricky.
=cut
sub send_message {
my $self = shift;
my @values = [ @_ ];
print $self->{Whoami},$$, ": Now trying to send these values:
+", @values if $self->{DEBUG};
my $sckt = $self->{SOCKET};
#Eventually we need to have a very clever routine here to find
#a useful end-of-message sequence. For now, we pick it.
my $EOM = "END_OF_THE_MESSAGE\n";
my $d = Data::Dumper->new(\@values,[qw"values"]);
$d->Purity(1)->Terse(0)->Deepcopy(1)->Indent(1)->Useqq(1);
my $message = $d->Dump;
$message = pack "u", $message;
print $self->{Whoami}, " $$: Sent message ", $message, "\n" if
+ $self->{DEBUG};
my @ready = $self->{SELECT}->can_write();
print scalar(@ready) ? "" : "Socket not ready to write to\n";
foreach my $connection (@ready) {
my $result = print $connection $EOM, $message, $EOM;
$self->_inactivate unless $result;
}
return 1;#$result;
}
sub _inactivate {
my $self = shift;
$self->_debug ("Inactivating ", $self->{PID}, "\n");
$self->{ACTIVE} = undef;
if ( $self->{PARENT} ) {
#Remove child pid from list of children, which will on
+ly work if we are the parent
my $child_pid = $self->{CHILD_PID};
$forkMe::children{$child_pid} = undef;
}
}
=item message_waiting
C<if ($fork-E<gt>message_waiting) { do_something }>
Returns the number of messages in the queue
=cut
sub message_waiting {
my $self = shift;
$self->_read_messages;
#return the number of messages in the queue
return @{$self->{MSG_QUEUE}};
}
=item is_active
The object could become inactive if the child or parent dies, or if th
+e TCP socket closes for some reason
(like the machines administrator shuts down the networking stack). Use
+ this in preference to accessing the hash
directly.
=cut
sub is_active {
my $self = shift;
return undef unless $self->{ACTIVE};
my $active = 1;
if ( $self->{PARENT} ) {
#Windows machines don't do signals, so we have to chec
+k
$active = waitpid( $self->{CHILD_PID}, &WNOHANG ) ? 0
+ : 1;
$self->_debug( "Waitpid returns $active and state: $?"
+);
}
return $active;
}
sub is_parent {
my $self = shift;
return $self->{PARENT} ? 1 : 0;
}
sub is_child {
my $self = shift;
return $self->{PARENT} ? 0 : 1;
}
=item C<$fork-E<GT>who_am_i;>
Returns 'parent' or 'child' depnding on who we are in this particular
+ C<$fork>
=cut
sub who_am_i {
my $self = shift;
return undef unless $self->is_active;
return !$self->{CHILD_PID} ? 'child' : 'parent';
}
=back
=head1 Public Variables
Don't change 'em, just use 'em.
=over 4
=item C<$fork-E<gt>{PARENT},$fork-E<gt>{CHILD}>
One will always be true, the other always false. Note that it returns
+ the relationship for that particular fork.
If you fork, then the child forks, the one in the middle will be the
+ child of
the first process and the parent
of the second.
e.g.
$fork1-E<gt>{PARENT}; #False
$fork2-E<gt>{PARENT}; #True
=item C<$fork-E<gt>{ACTIVE}>
True if the module thinks that both programs in the fork are still the
+re, and that it is possible to communicate
between them. Since this can only be checked when the module gets co
+ntrol, C<call $fork-<gt>is_active> before
working with the object, or you may get a nasty suprise.
=item C<$fork-E<gt>{WHOAMI},$fork-E<gt>{Whoami}>
Will return "PARENT" or "CHILD" depending on whether the current proce
+ss is the
parent or the child.
I only ever use it for printing out messages like:
C<print "This the the ", $fork-E<gt>{Whoami}, " process\n";>
=item C<$fork-E<gt>{CHILD_PID},$fork-E<gt>{PARENT_PID}>
CHILD_PID holds the childs PID. PARENT_PID holds the parents pid.
=item C<$fork-E<gt>{PID}>
PID is the process number of the current process.
=item C<$fork-E<GT>{OTHER_PID>
Returns the PID of the other process in the fork, whatever it is.
=item C<$fork-E<gt>{DEBUG}>
Switches on verbose output so you can see what's going on.
=back
=head1 Examples
I prefer to fork and have the child run the backend while the parent p
+rocess
handles user interface. My friends (all C coders) prefer to do the r
+everse. They
like to start a server and then fork off children to do tasks. So I
+prefer to fork
like this:
C<my $fork = new ForkMe("silent_children slay_children") or die "Could
+n't fork:
$@\n";>
C<if ($fork-E<gt>{PARENT} ){
print "I am the parent.\n";
}
else {
print "I am the child. I'm going to run around and break thin
+gs because you can't see me.\n";
}
>
while my friends, if they programmed Perl, would do it like this:
C<my $fork = new ForkMe("silent_parents slay_parents") or die "Couldn'
+t fork: $@\n";>
C<if ($fork-E<gt>{PARENT} ){
print "I am the parent. I will silently work until I drop.\n"
+;
}
else {
print "I am the child. Look at me! Look at me!\n";
}
>
It supports multiple forks as well:
use ForkMe;
use strict;
use warnings;
use diagnostics;
my $fork2;
my $fork = new ForkMe("slay_children") or die "Couldn't fork: $@\n";
if ( $fork->{PARENT} ) {
$fork2 = new ForkMe("slay_children") or die "Could fork a seco
+nd time: $@\n";
}
if ( $fork->is_active ) {
if ( $fork->{CHILD} ) {
$fork->send_message( "This is the ", $$, " process say
+ing hello") or die "Couldn't send message: $@\n";
}
else{
sleep 1;
while ( !( $fork->message_waiting) ) {sleep 2;};
my @temp = $fork->read_message or die "Couldn't read m
+essage: $@\n";
print "This the the ", $fork->{Whoami}, $$;
print " process, and I just received a message. \n";
print "It reads:\n\"",@temp, "\"\n\n\n--------------\n
+";
}
}
if ( $fork2 && $fork2->is_active ) {
if ( $fork2->{CHILD} ) {
print ".";$fork2->send_message( "This is the ", $$, "
+process saying hello") or die "Couldn't send message: $@\n";
}
else {
sleep 1;
my @temp = $fork2->read_message or die "Couldn't read
+message: $@\n";
print "This the the ", $fork->{Whoami}, $$;
print " process, and I just received a message. ";
print "It reads:\n\"",@temp, "\"\n\n\n--------------\n
+";
}
}
if ( ($fork->{PARENT}) or ($fork2->{PARENT}) ) {
print $fork->{WHOAMI};
print $fork2->{WHOAMI};
print " $$: going to sleep for a while\n";
sleep 5;
}
else{
sleep;
}
print "$$: Exiting\n";
=head1 TODO
The message passing routine needs to be smarter about picking it's mes
+sage delimiting characters.
The regular expressions for dealing with the messages are a mess.
I may be able to use SIGPIPE to tell if the other process has shut dow
+n. At the moment I just ignore it.
Possibly turn this into something that mediates the communication betw
+een two processes i.e. make the module
a third process so it can store messages and then hand them over when
+ asked for - effectively a TCP server handling messages
(I guess this is SYS V message queues, but with TCP).
Gah! Every time I use this the amount of work it needs doubles. I n
+eed a tracking system that hands back tokens so that I
can do 'RPC' calls effectively, rather than the C<$fork-E<gt>send_mes
+sage("Do something"); sleep 1; print $fork-E<gt>read_message;>
that I'm currently using. A C<while (! fork-E<gt>message_waiting)> i
+s no better, really.
=head1 Bugs
Should use FreezeThaw to serialise if it's available.
My regexps are shonky.
In my examples I use a variable called C<$fork> which will probably co
+nfuse beginners.
Tends to throw warnings about uninitialised variables. I tried to ini
+tialise all variables before use, but sometimes something undef
will come through the network connection.
=head1 Authors
jepri and larryk from Perlmonks
=cut
1; #all modules return true. It's a rule.
|
