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.
[download]