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 are many more options such as nonblocking forks, forks within forks, and 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 calls 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} option 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_children}){
			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->{nonblocking}){
		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 will result in the fork returning right away rather than waiting for any 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 false.

=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_nonblocking() 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 this, ALRM will be issued with in the fork once the sleep cycle 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.

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 on 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 cycle 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() (with interruption handling) use a select() call to sleep. This can be useful 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;