Ext::Fork is my own library, not published yet though will be Artistic 2 or GPL at some point.
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;
|