Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
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.

In reply to ForkMe by jepri

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others musing on the Monastery: (9)
    As of 2015-07-29 02:58 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (260 votes), past polls