File Coverage

blib/lib/Proc/Guard.pm

Criterion	Covered	Total	%
statement	24	66	36.3
branch	0	26	0.0
condition	0	17	0.0
subroutine	8	13	61.5
pod	4	4	100.0
total	36	126	28.5

package Proc::Guard;
use strict;
use warnings;
use 5.00800;
our $VERSION = '0.07';
use Carp ();

our $EXIT_STATUS;

# functional interface
our @EXPORT = qw/proc_guard/;
use Exporter 'import';
sub proc_guard {
    return Proc::Guard->new(do {
        if (@_==1 && ref($_[0])  && ref($_[0]) eq 'CODE') {
            +{ code => $_[0] }
        } else {
            +{ command => [@_] }
        }
    });
}

# OOish interface
use POSIX;
use Errno qw/EINTR ECHILD/;
use Class::Accessor::Lite 0.05 (
	rw => ['pid'],
);

sub new {
    my $class = shift;
    my %args = @_==1 ? %{$_[0]} : @_;

    my $self = bless {
        _owner_pid => $$,
        auto_start => 1,
        %args,
    }, $class;

    if ($self->{command} && !ref($self->{command})) {
        $self->{command} = [$self->{command}];
    }
    unless ($self->{command} || $self->{code}) {
        Carp::croak("'command' or 'code' is required.");
    }

    $self->start()
        if $self->{auto_start};

    return $self;
}

sub start {
    my $self = shift;

    my $pid = fork();
    die "fork failed: $!" unless defined $pid;
    if ($pid == 0) { # child
        if ($self->{command}) {
            exec @{$self->{command}};
            die "cannot exec @{$self->{command}}: $!";
        } else {
            $self->{code}->();
            exit(0); # exit after work
        }
    }
    $self->pid($pid);
}

sub stop {
    my ( $self, $sig ) = @_;
    return
        unless defined $self->pid;
    $sig ||= SIGTERM;

    kill $sig, $self->pid;
    LOOP: {
        if ( waitpid( $self->pid, 0 ) > 0 ) {
            $EXIT_STATUS = $?;
            last LOOP;
        }

        redo LOOP if $! == EINTR;

        # on any other error, we have no reason to think that
        # trying again will succeed; on ECHILD, that pid is gone
        # or not ours, so give up; anything else is strange
        warn "waitpid() error: $!\n" if $! != ECHILD;

        # waitpid wasn't successful so $? is undefined
        $EXIT_STATUS = undef;
    }

    $self->pid(undef);
}

sub DESTROY {
    my $self = shift;
    if (defined $self->pid && $$ == $self->{_owner_pid}) {
        local $?; # "END" function and destructors can change the exit status by modifying $?.(perldoc -f exit)
        $self->stop()
    }
}

1;
__END__