File Coverage

blib/lib/Proc/Find.pm

Criterion	Covered	Total	%
statement	88	106	83.0
branch	56	80	70.0
condition	16	26	61.5
subroutine	10	13	76.9
pod	4	4	100.0
total	174	229	75.9

package Proc::Find;

our $DATE = '2015-01-03'; # DATE
our $VERSION = '0.04'; # VERSION

use 5.010001;
use strict;
use warnings;

use List::Util qw(first);

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(
                       find_proc
                       find_any_proc
                       find_all_proc
                       proc_exists
               );

our $CACHE = 0;

my $_table_res;
sub _table {
    state $pt = do {
        require Proc::ProcessTable;
        Proc::ProcessTable->new;
    };
    if (!$CACHE || !$_table_res) {
        $_table_res = $pt->table;
    }
    $_table_res;
}

sub find_proc {
    my %args = @_;

    my @unknown_args = grep {!/\A(
                                   pid|name|cmndline|exec|
                                   user|uid|euser|euid|
                                   table|detail|
                                   result_max
                               )\z/x} keys %args;
    die "Unknown arguments to find_proc(): ".join(", ", @unknown_args)
        if @unknown_args;

    my $table = $args{table} // _table();

    my ($arg_uid, $arg_euid);

    my @res;
    for my $p (@$table) {
        # create extra fields
        $p->{name} = $p->{cmndline};
        $p->{name} =~ s/\s.*//;
        $p->{name} =~ s!.+/!!;

        my $cond = 0;
      COND:
        {
            if (defined $args{pid}) {
                last COND unless $p->{pid} == $args{pid};
            }
            if (defined $args{name}) {
                if (ref($args{name}) eq 'Regexp') {
                    last COND unless $p->{name} =~ $args{name};
                } else {
                    last COND unless $p->{name} eq $args{name};
                }
            }
            if (defined $args{cmndline}) {
                if (ref($args{cmndline}) eq 'Regexp') {
                    last COND unless $p->{cmndline} =~ $args{cmndline};
                } else {
                    last COND unless $p->{cmndline} eq $args{cmndline};
                }
            }
            if (defined $args{exec}) {
                my $exec = $p->{exec} // '';
                unless ($args{exec} =~ m!/!) {
                    $exec =~ s!.+/!!;
                }
                last COND unless $exec eq $args{exec};
            }
            if (defined($args{user}) || defined($args{uid})) {
                my $val = $args{user} // $args{uid};
                my $uid;
                if ($val =~ /\A\d+\z/) {
                    $uid = $val;
                } else {
                    if (!defined($arg_uid)) {
                        my @pw = getpwnam($val);
                        $arg_uid = @pw ? $pw[2] : -1;
                    }
                    $uid = $arg_uid;
                }
                last COND unless $p->{uid} == $uid;
            }
            if (defined($args{euser}) || defined($args{euid})) {
                my $val = $args{euser} // $args{euid};
                my $euid;
                if ($val =~ /\A\d+\z/) {
                    $euid = $val;
                } else {
                    if (!defined($arg_euid)) {
                        my @pw = getpwnam($val);
                        $arg_euid = @pw ? $pw[2] : -1;
                    }
                    $euid = $arg_euid;
                }
                last COND unless $p->{euid} == $euid;
            }

            $cond = 1;
        }

        $cond = !$cond if $args{inverse};
        next unless $cond;

        if ($args{detail}) {
            push @res, { %$p }; # unbless
        } else {
            push @res, $p->{pid};
        }

        if (defined $args{result_max}) {
            last if @res >= $args{result_max};
        }
    }

    \@res;
}

sub proc_exists {
    @{ find_proc(@_, result_max=>1) } > 0 ? 1:0;
}

sub find_any_proc {
    return [] unless @_;

    my $detail = $_[0]->{detail};
    my $table = $_[0]->{table} // _table();

    my @allres;
    for my $crit (@_) {
        my $res = find_proc(%$crit, table=>$table, detail=>$detail);
      ITEM:
        for my $item (@$res) {
            # skip duplicate process
            if ($detail) {
                next ITEM if first {$_->{pid} == $res->{pid}} @allres;
            } else {
                next ITEM if first {$_ == $res} @allres;
            }
            push @allres, @$res;
        }
    }

    \@allres;
}

sub find_all_proc {
    return [] unless @_;

    my $detail = $_[0]->{detail};
    my $table = $_[0]->{table} // _table();

    my @allres;
  CRIT:
    for my $crit (@_) {
        my $res = find_proc(%$crit, table=>$table);
        if (!@allres) {
            push @allres, @$res;
            next CRIT;
        }
        @allres = grep {
            my $p = $_;
            $detail ?
                ((first {$p->{pid} == $_->{pid}} @$res) ? 1:0) :
                ((first {$p == $_} @$res) ? 1:0)
        } @allres;
    }

    \@allres;
}

1;
# ABSTRACT: Find processes by name, PID, or some other attributes

__END__