Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer

comment on

( [id://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

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!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • 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?

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

    How do I use this?Last hourOther CB clients
    Other Users?
    Others wandering the Monastery: (2)
    As of 2024-07-25 04:20 GMT
    Find Nodes?
      Voting Booth?

      No recent polls found

      erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.