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 IPC.  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 module 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 failure.  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 anything else except convenient.
  I just got sick of spending half and hour going through the IPC docos (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 safely 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_message;}>

        #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); sprintf "%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_pid);
                $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 $ForkMe::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 IPC, as described above.  There are some options
 you can pass to it.  All  options are passed as one long string, separated 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 other 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>{DEBUG}=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_children/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: $!" ) and return;
        if ( $pid > 0 ) {
                #We are the parent
                $self->{PARENT} = 1; $self->{CHILD} = 0; $self->{WHOAMI} = "PARENT"; $self->{Whoami} = "Parent";
                $self->{CHILD_PID} = $pid;  $self->{PID} = $$; $self->{OTHER_PID} = $pid;
                $self->_debug( "Successfully forked, I am the parent of child ",$self->{CHILD_PID});

                if (  $self->{SOCKET} = $listen_sock->accept() ) {  
                        $self->{SOCKET}->autoflush(1);
                        $self->{SELECT} = IO::Select->new($self->{SOCKET});

                        #I don't know of a way to tell the child if the parent quits
                        #The parent will receive a SIGCHLD when the child quits
                        $SIG{CHLD}=\&REAPER;

                        if ( $self->{PARENT} && $self->{PARENTS_NOT_SEEN_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 tracking hash");
                   $ForkMe::children{$pid} = $self;
                   $self->_debug( "Accepted incoming connection and returning 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 receive 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 processes
                        foreach my $pd (keys %ForkMe::children) {
                                print $self->{Whoami}, "$$: Now swatting 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} = undef;
                                $ForkMe::children{$pd}->{CHILD} = undef;
                                $ForkMe::children{$pd}->{WHOAMI} = "blah!"; #undef;
                                $ForkMe::children{$pd}->{Whoami} = "Blah!";
                                $ForkMe::children{$pd}->{CHILD_PID} = "blah!"; #undef;

                                $ForkMe::children{$pd}->{PID} = "blah!"; #undef;                                $ForkMe::children{$pd}->{ACTIVE} = undef;
                                print $self->{Whoami}, "$$: Finished swatting refs to  $pd\n" if $self->{DEBUG};
                        }
                        delete @ForkMe::children{keys %ForkMe::children};

                        #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 doesn'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_children = ", $self->{CHILDREN_NOT_SEEN_OR_HEARD};
                           open STDIN,  "</dev/null";
                           open STDOUT, ">/dev/null";
                           open STDERR, ">/dev/null";
                   }
                   print "Child $$:  Connected successfully and now returning 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 the 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), " characters 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 overflow!!!!
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 otherwise.  There may be an error message in $@.

I have tried this with lists and lists of hashes, both of which go through fine.  It relies on Data::Dumper to
bundle up your varibales and send them through.  I still recommend against 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 only 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 the 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 check
                $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 there, and that it is possible to communicate
 between them.  Since this can only be checked when the module gets control, 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 process 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 process
 handles user interface.  My friends (all C coders) prefer to do the reverse.  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 "Couldn'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 things 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 second time: $@\n";
}

if ( $fork->is_active ) {
        if ( $fork->{CHILD} ) {
                $fork->send_message( "This is the ", $$, " process saying 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 message: $@\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 message 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 down.  At the moment I just ignore it.

Possibly turn this into something that mediates the communication between 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 need a tracking system that hands back tokens so that I
 can do 'RPC' calls effectively, rather than the C<$fork-E<gt>send_message("Do something"); sleep 1; print $fork-E<gt>read_message;>
 that I'm currently using.  A C<while (! fork-E<gt>message_waiting)> is 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 confuse beginners.

Tends to throw warnings about uninitialised variables.  I tried to initialise 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.