ForkMe

[jepri]

Category:

Miscellaneous

Description:

A module that handles some of the hairier aspects of forking and communicating between processes.

It has OO methods to fork and handle IPC between the processes using TCP network sockets. Comes with excessive POD and examples. It may even be easy to use. The POD may be slightly out of sync since this is a rush release. /msg me if any troubles occur

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.

[MeowChow]

You may also be interested in having a look at merlyn's parallel forking task manager, which implements similar functionality.

   MeowChow                                   
               s aamecha.s a..a\u$&owag.print

[jepri]

Dammit! I searched CPAN. I asked in the chatterbox. But I forgot to check merlyn's columns.

Not to worry, I'll be sure to incorporate the good features in the next version.

____________________
Jeremy
I didn't believe in evil until I dated it.

[premchai21]

Note that rather than using so many C<> blocks, you can create a 'verbatim' block by indenting your code lines with spaces. See perlpod.