File Coverage

blib/lib/BGS.pm

Criterion	Covered	Total	%
statement	58	78	74.3
branch	10	22	45.4
condition			n/a
subroutine	9	11	81.8
pod	4	4	100.0
total	81	115	70.4

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.08';

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


$SIG{CHLD} = "IGNORE";

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

my %callbacks = ();
my %fh2vpid   = ();
my %vpid2fh   = ();
my %vpid2pid  = ();


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

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

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

	if ($kid_pid) {
		$sel->add($from_kid_fh);
		$callbacks{$from_kid_fh} = $callback;
		$fh2vpid{$from_kid_fh} = $vpid;
		$vpid2fh{$vpid} = $from_kid_fh;
		$vpid2pid{$vpid} = $kid_pid;
	} else {
		binmode $to_parent_fh;
		print $to_parent_fh freeze \ scalar $sub->();
		close $to_parent_fh;
		exit;
	}
	return $vpid;
}

sub bgs_back(&) { shift }


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

				if (exists $from_kid{$fh}) {
	 				my $r = join "", @{$from_kid{$fh}};
 					delete $from_kid{$fh};
					$callbacks{$fh}->(${thaw $r});
				} else {
					$callbacks{$fh}->();
				}

				my $vpid = $fh2vpid{$fh};
 				delete $callbacks{$fh};
				delete $fh2vpid{$fh};
				if ($vpid) {
					delete $vpid2fh{$vpid};
					delete $vpid2pid{$vpid};
				}

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


sub _clean_by_vpid {
	my ($vpid) = @_;
	my $fh = $vpid2fh{$vpid} or return;

	$sel->remove($fh);
	close $fh;

	delete $callbacks{$fh};
	delete $fh2vpid{$fh};
	delete $vpid2fh{$vpid};
	delete $vpid2pid{$vpid};
}


sub bgs_break(;$) {
	my ($vpid) = @_;
	if (defined $vpid) {
		if (my $pid = $vpid2pid{$vpid}) {
			kill 15, $pid;
			1 while waitpid($pid, WNOHANG) > 0;
			_clean_by_vpid($vpid);
		}
	} else {
		local $SIG{TERM} = "IGNORE";
		kill 15, -$$;
		1 while waitpid(-1, WNOHANG) > 0;
		_clean_by_vpid($_) foreach keys %vpid2fh;
	}
}


1;


__END__