package FORKER;
use strict;

our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);

use Exporter;
$VERSION = 2008.166;
@ISA = qw(Exporter);

@EXPORT = qw(forker parsel mexit dethread); # symbols to autoexport (:DEFAULT tag)
@EXPORT_OK = qw(); # symbols to export on request
%EXPORT_TAGS = (
	job => [qw(forker parsel mexit dethread)],
	direct => [],
);

# BEGIN CODE
###################################################################
# FORK INTO AN ARBITRARY NUMBER OF THREADS AND RETURN THAT THREADS ID
sub forker {
	my ($nproc)=@_;
	my $id=0;
	
	# EXIT IF NOT INTEGER OR NUMBER OF PROCESSES <1
	if (int($nproc)!=$nproc or $nproc<1) {print "NUMBER OF THREADS MUST BE A POSITIVE INTEGER > 0!\n" and exit(5000);}
	
	# FIND MAXIMUM INTEGER EXPONENT OF 2 <= NPROC
	my $intexp2=int(log($nproc)/log(2));
	
	# DIFFERENCE BETWEEN POWER OF 2 AND NPROC
	my $remain=$nproc-2**$intexp2;
	
	# FORK INTEXP2 TIMES
	for (my $i=1; $i<=$intexp2; $i++) {
		my $fo; until (defined($fo)) {$fo=fork; if (!defined($fo)) {print "FORK FAILED: FORK $i $id\n"}}
		($id*=2)+=!$fo;
	}
	
	# FORK OUT REMAINDER
	if ($id<$remain) {
		my $fo; until (defined($fo)) {$fo=fork; if (!defined($fo)) {print "FORK FAILED: FORK FINAL $id\n"}}
		if (!$fo) {$id+=$nproc-$remain;}
	}
	
	return $id;
}

# GIVES A SPECIFIC THREAD A SPECIFIC CHUNK OF A LIST BASED ON 
# THE NUMBER OF THREADS AND ITS ID
sub parsel {
	my ($id,$nproc,@list)=@_;
	
	# FLOAT DIVISION
	my $size=scalar(@list)/$nproc;
	
	# STARTING AND ENDING INDICES
	my $si=int($size*$id+0.5);
	my $ei=int($size*($id+1)+0.5)-1;
	
	# MAX OUT CHECK
	if ($ei>$#list) {print "BAD INDICE!\n"; $ei=$#list;}
	
	# CHECK FOR EMPTY LISTS
	if ($ei-$si<0) {undef(@list)}
	else {@list=@list[$si..$ei]}
	
	return @list;
}

# CLEAN, ORDERLY EXIT FOR THREAD
# WAIT FOR CHILD PROCESSES TO FINISH FIRST
# PASSES HIGHEST EXIT CODES UP THE LINE
sub mexit {
	my ($code)=@_;
	my $childpid=0;
	while ($childpid>=0) {
		$childpid=waitpid -1,0;
		my $childcode=$? >> 8;
		my $childsig=$? & 127;
		if ($childcode>$code) {$code=$childcode;}
		elsif ($childsig>$code) {$code=$childsig;}
	}
	exit($code); 
}

# CLEAN, ORDERLY EXIT FOR ALL THREADS EXCEPT PARENT
# PARENT CONTINUES ON ALONE
# PASSES HIGHEST EXIT CODES UP THE LINE
sub dethread {
	my ($code,$id)=@_;
	my $childpid=0;
	while ($childpid>=0) {
		$childpid=waitpid -1,0;
		my $childcode=$? >> 8;
		my $childsig=$? & 127;
		if ($childcode>$code) {$code=$childcode;}
		elsif ($childsig>$code) {$code=$childsig;}
	}
	if ($id>0) {exit($code)};
}

###################################################################
1;

