http://qs1969.pair.com?node_id=59619
Category: Miscellaneous
Author/Contact Info Brent Dax
brentdax1@earthlink.net
Description: This Perl module allows you to write forks like:
use ForkBlock; Fork { Parent { #parent code } Child { #child code } Error { #optional for handling non-recoverable errors } };

You use Fork if you want each process to terminate after its block, or DumbFork if you don't.

I'm not including the pod documentation, as it adds another hundred lines or so to the bottom of the script. If you want the source, including pod, e-mail me.

If nothing else, see it as a creative use of an anonymous hash.

Currently the only problem I have with it is that it doesn't croak if you forget the Parent or Child blocks, but I think that's pretty minor.

package ForkBlock;

use strict;
use vars qw/$CHILD_PID @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION/;
use Carp;
use Exporter;

@ISA=("Exporter");
@EXPORT=qw/Fork Parent Child Error/;
@EXPORT_OK=("DumbFork");
%EXPORT_TAGS=('all' => [qw/Fork Parent Child Error DumbFork/]);
$VERSION=0.02;

sub Fork {
    phork(@_) or croak "unable to fork: $!";
    exit(0);
}

sub DumbFork {
    phork(@_) or croak "unable to fork: $!";
}

sub Parent(&;%) { return "parent", @_ }
sub Child(&;%)  { return "child",  @_ }
sub Error(&;%)  { return "error",  @_ }

#private--implements the actual forking
sub phork {
    my %params=%{shift()};
    
    my $parent=$params{"parent"};
    my $child =$params{"child"} ;
    my $error =$params{"error"} ;
    
    local $!;

    FORK_IT: {
        if($CHILD_PID=fork()) {
            #i'm the parent
            &$parent;
        }
        elsif(defined($CHILD_PID)) {
            #i'm the child
            &$child;
        }
        else {
            #something went wrong
            if($! =~ /No more process/) {
                #recoverable, so wait a second and try again
                sleep 1;
                redo FORK_IT;
            }
            elsif(defined($error)) {
                    #something went wrong, but an Error block was defi
+ned
                    &$error;
            }
            else {
                #something went wrong, and the user forgot an Error bl
+ock
                return 0;
            }
        }
    }
    
    return 1;
}

1;