File Coverage

blib/lib/BGS.pm

Criterion	Covered	Total	%
statement	95	107	88.7
branch	21	34	61.7
condition	3	6	50.0
subroutine	14	14	100.0
pod	4	4	100.0
total	137	165	83.0

package BGS;

use strict;
use warnings;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(bgs_call bgs_back bgs_wait bgs_break);

our $VERSION = '0.11';

use IO::Select;
use Scalar::Util qw(refaddr);
use Storable qw(freeze thaw);
use POSIX ":sys_wait_h";


our $limit = 0;

$SIG{CHLD} = "IGNORE";

my $sel = IO::Select->new();

my %fh2data   = ();
my %vpid2data = ();

my @to_call = ();


sub _call {
	my ($data) = @_;

	my $sub = delete $$data{sub};

	pipe my $from_kid_fh, my $to_parent_fh or die "pipe: $!";

	my $kid_pid = fork;
	defined $kid_pid or die "Can't fork: $!";

	if ($kid_pid) {
		$sel->add($from_kid_fh);

		my $vpid = $$data{vpid};

		$$data{fh}  = $from_kid_fh;
		$$data{pid} = $kid_pid;

		$fh2data{$from_kid_fh} = $data;
		$vpid2data{$vpid}      = $data;

	} else {
		binmode $to_parent_fh;
		print $to_parent_fh freeze \ scalar $sub->();
		close $to_parent_fh;
		exit;
	}

}


sub _bgs_call {
	my ($sub, $callback) = @_;

	my $data = { sub => $sub };
	my $vpid = $$data{vpid} = refaddr $data;

	$$data{callback} = $callback if $callback;

	if ($limit > 0 and keys %fh2data >= $limit) {
		push @to_call, $data;
	} else {
		_call($data);
	}

	return $data;
}

sub bgs_call(&$) {
	my ($sub, $callback) = @_;

	my $data = _bgs_call($sub, $callback);

	return $$data{vpid};
}

sub bgs_back(&) { shift }


sub bgs_wait(;$) {
	my ($waited) = @_;

	local $SIG{PIPE} = "IGNORE";
	my $buf;
	my $blksize = 1024;
	while ($sel->count()) {
		foreach my $fh ($sel->can_read()) {
			my $data = $fh2data{$fh};
			my $len = sysread $fh, $buf, $blksize;
			if ($len) {
				push @{$$data{from_kid}}, $buf;
			} elsif (defined $len) {
				$sel->remove($fh);
				close $fh or warn "Kid is existed: $?";

				delete $$data{fh};
				delete $$data{pid};
				my $callback = delete $$data{callback};

				if (exists $$data{from_kid}) {
					my $r = join "", @{$$data{from_kid}};
					delete $$data{from_kid};
					if ($callback) {
						$callback->(${thaw $r});
					} else {
						$$data{result} = ${thaw $r};
					}
				} else {
					if ($callback) {
						$callback->();
					} else {
						$$data{result} = undef;
					}
				}

				my $vpid = $$data{vpid};
				delete $fh2data{$fh};
				delete $vpid2data{$vpid};

				if (my $call = shift @to_call) {
					_call($call);
				}

				if ($waited and $waited == $vpid) {
					return;
				}

			} else {
				die "Can't read '$fh': $!";
			}
		}
	}
}


sub _clean {
	my ($data) = @_;
	my $vpid = $$data{vpid};
	delete $vpid2data{$vpid};
	my $fh = $$data{fh} or return;
	$sel->remove($fh);
	close $fh;
	delete $fh2data{$fh};
}


sub bgs_break(;$) {
	my ($vpid) = @_;
	if (defined $vpid) {
		my $data = $vpid2data{$vpid};
		defined $data or return;
		if (my $pid = $$data{pid}) {
			kill 15, $pid;
			1 while waitpid($pid, WNOHANG) > 0;
		}
		_clean($data);
		 @to_call = grep { $$_{vpid} ne $vpid } @to_call;
	} else {
		local $SIG{TERM} = "IGNORE";
		kill 15, -$$;
		1 while waitpid(-1, WNOHANG) > 0;
		_clean($_) foreach values %vpid2data;
		@to_call = ();
	}
}


1;


__END__