The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

package Proc::Parallel::RemoteKiller;

use strict;
use warnings;
use File::Slurp::Remote::BrokenDNS qw($myfqdn %fqdnify);
use Scalar::Util qw(weaken);

my %active;

sub new
{
	my $pkg = shift;
	my $self = bless { hosts => {} }, $pkg;
	$self->{old_sig} = $SIG{INT};
	$SIG{INT} = sub { $self->kill_them_all };
	$active{"$self"} = $self;
	weaken($active{"$self"});
	return $self;
}

sub note
{
	my ($self, $host, $pid) = @_;
	$host = $myfqdn unless defined $host;
	my $precache_answer = $fqdnify{$host};
	$self->{hosts}{$host}{$pid} = 1;
}

sub forget
{
	my ($self, $host, $pid) = @_;
	return unless defined($host) && defined($pid);
	delete $self->{hosts}{$host}{$pid};
	delete $self->{hosts}{$host} unless keys %{$self->{hosts}{$host}};
}

sub forget_all
{
	my ($self) = @_;
	$self->{hosts} = {};
}

sub kill_them_all
{
	my ($self, $do_not_exit) = @_;

	print STDERR "Bailing out!\n" unless $do_not_exit;

	my $x = "set -x\n";
	my $wait = 0;
	my $do = 0;
	for my $host (keys %{$self->{hosts}}) {
		my @pids = keys %{$self->{hosts}{$host}};
		delete $self->{hosts}{$host};
		next unless @pids;
		if ($fqdnify{$host} eq $myfqdn) {
			$x .= "kill @pids\n";
			$do = 1;
		} else {
			$x .= "ssh -o StrictHostKeyChecking=no $host -n kill @pids &\n";
			$wait = 1;
		}
	}
	$x .= "wait\n" if $wait;
	system($x) if $do || $wait; 
	exit(0);
}

sub DESTROY
{
	my ($self) = @_;
	delete $SIG{INT};
	# $self->kill_them_all(1);
	delete $active{"$self"};
}

END {
	for my $rk (values %active) {
		next unless $rk;
		$rk->kill_them_all(1);
	}
}


1;

__END__

=head1 NAME

Proc::Parallel::RemoteKiller - kill off slave processes on control-C

=head1 SYNOPSIS

 use Proc::Parallel::RemoteKiller;

 $remote_killer = Proc::Parallel::RemoteKiller->new;

 $remote_killer->note($host, $pid);

 $remote_killer->forget($host, $pid);

 $remote_killer->kill_them_all();

 $remote_killer->forget_all();

=head1 DESCRIPTION

This module tries to make control-C work when you've got remote slave
processes.  It maintains a list of such processes and catches 
C<$SIG{INT}>.  

You tell it about new processes with C<note>.  You tell it to forget
about processes with C<forget> and C<forget_all>.  You can ask that 
they all be terminated with C<kill_them_all()>.

It uses C<ssh> to get to the remote systems to kill the processes.

=head1 LICENSE

This package may be used and redistributed under the terms of either
the Artistic 2.0 or LGPL 2.1 license.