package Ext::Fork;
# @@COPYRIGHT@@

$VERSION = '@@VERSION@@';

# Version number - cvs automagically updated.
our $VERSION = '$Revision: 1.3 $';

use strict;
use POSIX ('WNOHANG','setsid');

require Exporter;

# Try and use high resolution timing
if(eval 'use Time::HiRes qw(usleep);'){
    $Ext::Fork::has_thr = 1 if !$Ext::Fork::no_thr;
}

# Exported routines
our @ISA = ('Exporter');
our @EXPORT = qw(
    rfork
    rfork_wait
    rfork_init
    rfork_maxchildren
    rfork_errstr
    rfork_is_child
    rfork_has_children
    rfork_nonblocking
    rfork_daemonize
    rfork_sleep
    rfork_usleep
    rfork_ssleep
    rfork_active_children
    rfork_kill_children
    rfork_list_children
    rfork_child_dob
);

# Defaults
&rfork_init();

require 5.008;

our $VERSION = '$Revision: 1.3 $';

=head1 NAME

Ext::Fork - A simple library of routines to manage forking.

=head1 DESCRIPTION

This library functions much the same way as Proc::Fork except there ar
+e many more options such as nonblocking forks, forks within forks, an
+d high resolution timing

=head1 SYNOPSIS

 #!/usr/bin/perl 
 use Ext::Fork;
 use Fcntl ':flock';

 # Initialize the system allowing 25 forks per rfork() level
 rfork_init(25);

 for(my $i = 0; $i < 100; $i++){
    # Fork this if possible, if all avaliable fork slots are full
    # block until one becomes avaliable.
    rfork(sub {
        # Lock STDOUT for writing.
        flock(STDOUT, &LOCK_EX);

        # Print out a string.
        print STDOUT "Fork: $_\n";

        # Unlock STDOUT.
        flock(STDOUT, &LOCK_UN);
    });
 }

 # Wait until all forks have finished.
 rfork_wait();

=head1 METHODS

Note - because of the nature of forking within perl. I've decided not 
+to make this code object based. Rather it uses direct function calls 
+which are exported to the global namespace Below is a list of these c
+alls and how to access them.

=head2 rfork(code, code, code)

Provide managed forking functions.

Returns nothing on error and sets the rfork_errstr error handler.

if rfork() is called with in an rfork()ed process the calling rfork() 
+process will block until all children with in it die off.

=cut

sub rfork {
    if(!$Ext::Fork::POOL->{max_children}){
        return rfork_errstr("The $Ext::Fork::POOL->{max_children} opti
+on is required! Maybe you forgot to rfork_init()?");
    }

    if(!defined $Ext::Fork::POOL->{children}){
        $Ext::Fork::POOL->{children} = 0;
    }

    if(!defined $Ext::Fork::POOL->{max_children}){
        $Ext::Fork::POOL->{max_children} = 0;
    }

    while(1){
        if($Ext::Fork::POOL->{children} < $Ext::Fork::POOL->{max_child
+ren}){
            last;
        }

        if($Ext::Fork::has_thr){
            rfork_usleep(500);
        } else {
            rfork_sleep(1);
        }
    }

    if($Ext::Fork::POOL->{is_child}){
        $Ext::Fork::POOL->{has_children} = 1;
    }

    my $pid = fork;
    if($pid < 0){
        return rfork_errstr('ERROR: fork: ' . $!);
    } elsif($pid){
        $Ext::Fork::POOL->{cidlist}->{$pid} = time();
        $Ext::Fork::POOL->{children}++;        
    } else {
        rfork_init();
        $Ext::Fork::POOL->{is_child} = 1;
        $SIG{PIPE} = 'IGNORE';
        for my $code (@_){
            if(ref($code) eq 'CODE'){
                &{ $code };            
            }               
        }

        exit(2);
     } 

    if($Ext::Fork::POOL->{has_children} && !$Ext::Fork::POOL->{nonbloc
+king}){
        while(1){
            last if !$Ext::Fork::POOL->{children};
            if($Ext::Fork::has_thr){
                rfork_usleep(500);
            } else {    
                rfork_sleep(1);
            }
        }
     }

    return $pid;
} 

=head2 rfork_nonblocking(BOOL)

Set the rfork() behavior to nonblocking mode if <BOOL> is true, This w
+ill result in the fork returning right away rather than waiting for a
+ny possible children to die.

=cut

sub rfork_nonblocking {
    $Ext::Fork::POOL->{nonblocking} = $_[0];
}

=head2 rfork_is_child()

Return true if called with in a forked enviroment, otherwise return fa
+lse.

=cut

sub rfork_is_child {
    return $Ext::Fork::POOL->{is_child};
}

=head2 rfork_has_children()

Return true if children exist with in a forked enviroment.

=cut

sub rfork_has_children {
    return $Ext::Fork::POOL->{has_children};
}

=head2 rfork_errstr()

Return the last error message.

=cut

sub _sigchld {
    while((my $p = waitpid(-1, WNOHANG)) > 0){ 
        delete $Ext::Fork::POOL->{cidlist}->{$p};
        $Ext::Fork::POOL->{children} -- if $Ext::Fork::POOL->{children
+};        
    }

    # self reference
    $SIG{CHLD} = \&Ext::Fork::_sigchld; 
}

=head2 rfork_init(children)

Initialize the CHLD reaper with a maximum number of <childre>

This should be called prior to any rfork() calls

=cut

sub rfork_init {
    $Ext::Fork::POOL = {};
    $Ext::Fork::POOL->{children} = 0;
    $Ext::Fork::POOL->{cidlist}  = {};
    $Ext::Fork::POOL->{is_child} = 0;

    if($_[0]){
        $Ext::Fork::POOL->{max_children} = $_[0];
        $SIG{CHLD} = \&Ext::Fork::_sigchld;
    }
}

=head2 rfork_maxchildren(int)

Set/Reset the maximum number of children allowed.

=cut

sub rfork_maxchildren {
    $Ext::Fork::POOL->{max_children} = $_[0] if $_[0];
}

=head2 rfork_wait()

Block until all rfork() children have died off unless rfork_nonblockin
+g() is enabled.

=cut

sub rfork_wait {
    return 1 if $Ext::Fork::POOL->{nonblocking};

    while(1){
        last if !$Ext::Fork::POOL->{children};

        if($Ext::Fork::has_thr){
            rfork_usleep(500);
        } else {
            rfork_sleep(1);
        }
    }

    return 1;
}

=head2 rfork_active_children()

Return the total number of active children.

=cut

sub rfork_active_children {
    return ($Ext::Fork::POOL->{children} ? $Ext::Fork::POOL->{children
+} : 0);
}

=head2 rfork_daemonize(BOOL)

Daemonize the the calling script.

If <BOOL> is true write _ALL_ output to /dev/null.

=cut

sub rfork_daemonize {
    my $q = $_[0];
    chdir('/') || die "Can't chdir to /: $!\n";
    if(!$q){
        open STDIN,  '/dev/null'   || die "Can't read /dev/null: $!\n"
+;
        open STDOUT, '>/dev/null'  || die "Can't write to /dev/null: $
+!\n";
        open STDERR, '>&STDOUT'    || die "Can't dup stdout: $!";
    }

    defined(my $pid = fork) || die "Can't fork: $!\n";
    exit(0) if $pid;
    setsid || die "Can't start a new session: $!\n";
}

=head2 rfork_sleep(int)

Provides an alarm safe sleep() wrapper. Beacuse we sleep() with in thi
+s, ALRM will be issued with in the fork once the sleep cycle has comp
+leted. This function wraps sleep with in a while() block and tests to
+ make sure that the seconds requested for the sleep were slept.

Also, setting $Ext::Fork::select_sleep to a true value will bypass all
+ standard sleep() handling (including interuption handling) and use a
+ system select() call to preform a blocking timeout. This is useful o
+n systems with a malfunctioning sleep() call.

=cut

sub rfork_sleep {
    my $sleep = $_[0];
    return if $sleep !~ /^\d+$/;

    if($Ext::Fork::select_sleep){
        select(undef, undef, undef, $sleep);
         return $sleep;
    }

    my $sleeper = 0;
    my $slept = 0;

    while(1){
        if($sleeper < 0 || $sleep <= 0){
            last;
        } elsif(!$sleeper) {
            $sleeper = $sleep;
        }

        my $remain = sleep( abs($sleeper) );

        if($remain ne $sleeper && $remain < $sleep){
            $slept += $remain;
            $sleeper = $sleeper - $remain;

            next;
        } else {
            last;
        }
    }

    return $slept;
}

=head2 rfork_usleep(int)

Provides an alarm safe Time::HiRes usleep() wrapper. Beacuse we sleep(
+) with in this, ALRM will be issued with in the fork once the sleep c
+ycle has completed. This function wraps sleep with in a while() block
+ and tests to make sure that the seconds requested for the sleep were
+ slept.

This function is only avaliable if Time::HiRes is avaliable otherwise 
+it will simply return nothing at all.

Note, setting $Ext::Fork::no_thr (No Time::HighRes) will disable high 
+resolution timing.

=cut

sub rfork_usleep {
    my $sleep = $_[0];
    return if $sleep !~ /^\d+$/;

    my $sleeper;
    my $slept = 0;

    while(1){
        if($sleeper < 0 || $sleep <= 0){
            last;
        } elsif(!$sleeper) {
        $sleeper = $sleep;
        }

        my $remain = usleep( abs($sleeper) );

        if($remain ne $sleeper && $remain < $sleep){
            $slept += $remain;
            $sleeper = $sleeper - $remain;

            next;
        } else {
            last;
        }
    }

    return $slept;
}

=head2 rfork_ssleep(int)

Preform an rfork_sleep() except rather than using standard sleep() (wi
+th interruption handling) use a select() call to sleep. This can be u
+seful in environments where sleep() does not behave correctly, and a 
+select() will block for the desired number of seconds properly.

=cut

sub rfork_ssleep {
    $Ext::Fork::select_sleep = 1;
    my $r = rfork_sleep(@_);
    $Ext::Fork::select_sleep = 0;
    return $r;
}

=head2 rfork_kill_children(SIGNAL)

Send all children (if any) this <SIGNAL>.

If the <SIGNAL> argument is omitted kill TERM will be used.

=cut

sub rfork_kill_children {
    my $sig = $_[0];
    if(!$sig){
        $sig = 'TERM';
    }

    if($Ext::Fork::POOL->{cidlist}){
        kill($sig, keys %{ $Ext::Fork::POOL->{cidlist} });
    }
}

=head2 rfork_list_children(BOOL)

Return a list of PID's currently running under this fork.

If BOOL is true a hash will be returned rather than a list.

=cut

sub rfork_list_children {
    my ($use_hash) = @_;

    if(!$Ext::Fork::POOL->{cidlist}){
        return;
    }

    if($use_hash){
        return %{ $Ext::Fork::POOL->{cidlist} };
    } else {
        return keys %{ $Ext::Fork::POOL->{cidlist} };
    }
}

=head2 rfork_child_dob(PID)

Return the EPOCH Date of Birth for this childs <PID>

Returns 0 if no child exists under that PID for this fork.

=cut

sub rfork_child_dob {
    my $pid = $_[0];
    if($Ext::Fork::POOL->{cidlist}->{$pid}){
        return $Ext::Fork::POOL->{cidlist}->{$pid};
    } else {
        return;
    }
}

1;
[download]