File Coverage

blib/lib/Unix/PID/Tiny.pm

Criterion	Covered	Total	%
statement	144	152	94.7
branch	89	106	83.9
condition	37	44	84.0
subroutine	16	17	94.1
pod	8	8	100.0
total	294	327	89.9

package Unix::PID::Tiny;

use strict;
use warnings;

our $VERSION = '0.94';

sub new {
    my ( $self, $args_hr ) = @_;

    my %DEFAULTS = (
        'keep_open'           => 0,
        'check_proc_open_fds' => 0
    );

    $args_hr ||= {};
    %{$args_hr} = ( %DEFAULTS, %{$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'},
        'keep_open'           => $args_hr->{'keep_open'},
        'check_proc_open_fds' => $args_hr->{'check_proc_open_fds'},
        'open_handles'        => []
    }, $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 _sets_match {
    my ( $left, $right ) = @_;

    my $count = scalar @{$left};

    return 0 unless scalar @{$right} == $count;

    for ( my $i = 0; $i < $count; $i++ ) {
        return 0 unless $left->[$i] eq $right->[$i];
    }

    return 1;
}

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

    my @pidfile_st = stat $pid_file or return;

    if ( defined $since ) {
        return if $pidfile_st[9] < $since;
    }

    if ( $self->{'check_proc_open_fds'} ) {
        my $dir   = "/proc/$pid/fd";
        my $found = 0;

        opendir my $dh, $dir or return;

        while ( my $dirent = readdir $dh ) {
            next if $dirent eq '.' || $dirent eq '..';

            my $path = "$dir/$dirent";
            my $dest = readlink $path or next;
            my @st   = stat $dest or next;

            if ( _sets_match( [ @pidfile_st[ 0, 1 ] ], [ @st[ 0, 1 ] ] ) ) {
                $found = 1;

                last;
            }
        }

        closedir $dh;

        return unless $found;
    }
    else {
        return unless $self->is_pid_running($pid);
    }

    return $pid;
}

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;
}

no warnings 'once';

# more intuitively named alias
*pid_file_no_cleanup = \&pid_file_no_unlink;
use warnings 'once';

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) );

    if ( $self->{'keep_open'} ) {
        push @{ $self->{'open_handles'} }, $pid_fh;
    }
    else {
        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__