File Coverage

blib/lib/Unix/PID/Tiny.pm

Criterion	Covered	Total	%
statement	3	109	2.7
branch	0	78	0.0
condition	0	39	0.0
subroutine	1	12	8.3
pod	8	8	100.0
total	12	246	4.8

package Unix::PID::Tiny;

use strict;
$Unix::PID::Tiny::VERSION = 0.91;

sub new {
    my ( $self, $args_hr ) = @_;
    $args_hr->{'minimum_pid'} = 11 if !exists $args_hr->{'minimum_pid'} || $args_hr->{'minimum_pid'} !~ m{\A\d+\z}ms;    # this does what one assumes m{^\d+$} would do

    if ( defined $args_hr->{'ps_path'} ) {
        $args_hr->{'ps_path'} .= '/' if $args_hr->{'ps_path'} !~ m{/$};
        if ( !-d $args_hr->{'ps_path'} || !-x "$args_hr->{'ps_path'}ps" ) {
            $args_hr->{'ps_path'} = '';
        }
    }
    else {
        $args_hr->{'ps_path'} = '';
    }

    return bless { 'ps_path' => $args_hr->{'ps_path'}, 'minimum_pid' => $args_hr->{'minimum_pid'} }, $self;
}

sub kill {
    my ( $self, $pid, $give_kill_a_chance ) = @_;
    $give_kill_a_chance = int $give_kill_a_chance if defined $give_kill_a_chance;
    $pid = int $pid;
    my $min = int $self->{'minimum_pid'};
    if ( $pid < $min ) {

        # prevent bad args from killing the process group (IE '0')
        # or general low level ones
        warn "kill() called with integer value less than $min";
        return;
    }

    # CORE::kill 0, $pid : may be false but still running, see `perldoc -f kill`
    if ( $self->is_pid_running($pid) ) {

        # RC from CORE::kill is not a boolean of if the PID was killed or not, only that it was signaled
        # so it is not an indicator of "success" in killing $pid
        _kill( 15, $pid );    # TERM
        _kill( 2,  $pid );    # INT
        _kill( 1,  $pid );    # HUP
        _kill( 9,  $pid );    # KILL

        # give kill() some time to take effect?
        if ($give_kill_a_chance) {
            sleep($give_kill_a_chance);
        }
        return if $self->is_pid_running($pid);
    }
    return 1;
}

sub is_pid_running {
    my ( $self, $check_pid ) = @_;

    $check_pid = int $check_pid;
    return if !$check_pid || $check_pid < 0;

    return 1 if $> == 0 && _kill( 0, $check_pid );    # if we are superuser we can avoid the the system call. For details see `perldoc -f kill`

    # If the proc filesystem is available, it's a good test. If not, continue on to system call
    return 1 if -e "/proc/$$" && -r "/proc/$$" && -r "/proc/$check_pid";

    # even if we are superuser, go ahead and call ps just in case CORE::kill 0's false RC was erroneous
    my @outp = $self->_raw_ps( 'u', '-p', $check_pid );
    chomp @outp;
    return 1 if defined $outp[1];
    return;
}

sub pid_info_hash {
    my ( $self, $pid ) = @_;
    $pid = int $pid;
    return if !$pid || $pid < 0;

    my @outp = $self->_raw_ps( 'u', '-p', $pid );
    chomp @outp;
    my %info;
    @info{ split( /\s+/, $outp[0], 11 ) } = split( /\s+/, $outp[1], 11 );
    return wantarray ? %info : \%info;
}

sub _raw_ps {
    my ( $self, @ps_args ) = @_;
    my $psargs = join( ' ', @ps_args );
    my @res = `$self->{'ps_path'}ps $psargs`;
    return wantarray ? @res : join '', @res;
}

sub get_pid_from_pidfile {
    my ( $self, $pid_file ) = @_;

    # if this function is ever changed to use $self as a hash object, update pid_file() to not do a class method call
    return 0 if !-e $pid_file;

    open my $pid_fh, '<', $pid_file or return;
    chomp( my $pid = <$pid_fh> );
    close $pid_fh;

    return int( abs($pid) );
}

sub is_pidfile_running {
    my ( $self, $pid_file ) = @_;
    my $pid = $self->get_pid_from_pidfile($pid_file) || return;
    return $pid if $self->is_pid_running($pid);
    return;
}

sub pid_file {
    my ( $self, $pid_file, $newpid, $retry_conf ) = @_;
    $newpid = $$ if !$newpid;

    my $rc = $self->pid_file_no_unlink( $pid_file, $newpid, $retry_conf );
    if ( $rc && $newpid == $$ ) {

        # prevent forked childrens' END from killing parent's pid files
        #   'unlink_end_use_current_pid_only' is undocumented as this may change, feedback welcome!
        #   'carp_unlink_end' undocumented as it is only meant for testing (rt57462, use Test::Carp to test END behavior)
        if ( $self->{'unlink_end_use_current_pid_only'} ) {
            eval 'END { unlink $pid_file if $$ eq ' . $$ . '}';    ## no critic qw(ProhibitStringyEval)
            if ( $self->{'carp_unlink_end'} ) {

                # eval 'END { require Carp;Carp::carp("[info] $$ !unlink $pid_file (current pid check)") if $$ ne ' . $$ . '}'; ## no critic qw(ProhibitStringyEval)
                eval 'END { require Carp;Carp::carp("[info] $$ unlink $pid_file (current pid check)") if $$ eq ' . $$ . '}';    ## no critic qw(ProhibitStringyEval)
            }
        }
        else {
            eval 'END { unlink $pid_file if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) eq $$ }';                          ## no critic qw(ProhibitStringyEval)
            if ( $self->{'carp_unlink_end'} ) {

                # eval 'END { require Carp;Carp::carp("[info] $$ !unlink $pid_file (pid file check)") if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) ne $$ }'; ## no critic qw(ProhibitStringyEval)
                eval 'END { require Carp;Carp::carp("[info] $$ unlink $pid_file (pid file check)") if Unix::PID::Tiny->get_pid_from_pidfile($pid_file) eq $$ }';    ## no critic qw(ProhibitStringyEval)
            }
        }
    }

    return 1 if defined $rc && $rc == 1;
    return 0 if defined $rc && $rc == 0;
    return;
}

*pid_file_no_cleanup = \&pid_file_no_unlink;                                                                                                                        # more intuitively named alias

sub pid_file_no_unlink {
    my ( $self, $pid_file, $newpid, $retry_conf ) = @_;
    $newpid = $$ if !$newpid;

    if ( ref($retry_conf) eq 'ARRAY' ) {
        $retry_conf->[0] = int( abs( $retry_conf->[0] ) );
        for my $idx ( 1 .. scalar( @{$retry_conf} ) - 1 ) {
            next if ref $retry_conf->[$idx] eq 'CODE';
            $retry_conf->[$idx] = int( abs( $retry_conf->[$idx] ) );
        }
    }
    elsif ( ref($retry_conf) eq 'HASH' ) {
        $retry_conf->{'num_of_passes'} ||= 3;
        $retry_conf->{'passes_config'} ||= [ 1, 2 ];
        $retry_conf = [ int( $retry_conf->{'num_of_passes'} ), @{ $retry_conf->{'passes_config'} } ];
    }
    else {
        $retry_conf = [ 3, 1, 2 ];
    }

    my $passes = 0;
    require Fcntl;

  EXISTS:
    $passes++;
    if ( -e $pid_file ) {
        my $curpid = $self->get_pid_from_pidfile($pid_file);

        # TODO: narrow even more the race condition where $curpid stops running and a new PID is put in
        # the file between when we pull in $curpid above and check to see if it is running/unlink below

        return 1 if int $curpid == $$ && $newpid == $$;    # already setup
        return if int $curpid == $$;                       # can't change it while $$ is alive
        return if $self->is_pid_running( int $curpid );

        unlink $pid_file;                                  # must be a stale PID file, so try to remove it for sysopen()
    }

    # write only if it does not exist:
    my $pid_fh = _sysopen($pid_file);
    if ( !$pid_fh ) {
        return 0 if $passes >= $retry_conf->[0];
        if ( ref( $retry_conf->[$passes] ) eq 'CODE' ) {
            $retry_conf->[$passes]->( $self, $pid_file, $passes );
        }
        else {
            sleep( $retry_conf->[$passes] ) if $retry_conf->[$passes];
        }
        goto EXISTS;
    }

    print {$pid_fh} int( abs($newpid) );
    close $pid_fh;

    return 1;
}

sub _sysopen {
    my ($pid_file) = @_;
    sysopen( my $pid_fh, $pid_file, Fcntl::O_WRONLY() | Fcntl::O_EXCL() | Fcntl::O_CREAT() ) || return;
    return $pid_fh;
}

sub _kill {    ## no critic(RequireArgUnpacking
    return CORE::kill(@_);    # goto &CORE::kill; is problematic
}

1;

__END__