File Coverage

blib/lib/Proc/Find.pm

Criterion	Covered	Total	%
statement	98	113	86.7
branch	70	98	71.4
condition	16	26	61.5
subroutine	11	14	78.5
pod	4	4	100.0
total	199	255	78.0

package Proc::Find;

our $DATE = '2019-11-23'; # DATE
our $VERSION = '0.051'; # 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 _match {
    my ($target, $cond, $is_numeric) = @_;
    if (ref $cond eq 'Regexp') {
        return 0 unless $target =~ $cond;
    } elsif (ref $cond eq 'ARRAY') {
        return 0 unless grep { $is_numeric ? $target == $_ : $target eq $_ } @$cond;
    } else {
        return 0 unless $is_numeric ? $target == $cond : $target eq $cond;
    }
    1;
}

sub find_proc {
    my %args = @_;

    my @unknown_args = grep {!/\A(
                                   filter|
                                   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{filter}) {
                local $_ = $p;
                last COND unless $args{filter}->($p);
            }
            if (defined $args{pid})      { last COND unless _match($p->{pid}     , $args{pid}     , 1) }
            if (defined $args{name})     { last COND unless _match($p->{name}    , $args{name}    ) }
            if (defined $args{cmndline}) { last COND unless _match($p->{cmndline}, $args{cmndline}) }
            if (defined $args{exec}) {
                my $exec = $p->{exec} // '';
                unless ($args{exec} =~ m!/!) {
                    $exec =~ s!.+/!!;
                }
                last COND unless _match($exec, $args{exec});
            }
            if (defined($args{user}) || defined($args{uid})) {
                my $cond = $args{user} // $args{uid};
                if ($cond eq 'Regexp') {
                    last COND unless _match($p->{uid}, $cond, 1); # XXX allow matching against username?
                } else {
                    my @uids;
                    for my $val (ref $cond eq 'ARRAY' ? @$cond : $cond) {
                        if ($val =~ /\A\d+\z/) {
                            push @uids, $val;
                        } else {
                            my @pw = getpwnam($val);
                            push @uids, @pw ? $pw[2] : -1;
                        }
                    }
                    last COND unless _match($p->{uid}, \@uids, 1);
                }
            }
            if (defined($args{euser}) || defined($args{euid})) {
                my $cond = $args{euser} // $args{euid};
                if ($cond eq 'Regexp') {
                    last COND unless _match($p->{euid}, $cond, 1); # XXX allow matching against username?
                } else {
                    my @uids;
                    for my $val (ref $cond eq 'ARRAY' ? @$cond : $cond) {
                        if ($val =~ /\A\d+\z/) {
                            push @uids, $val;
                        } else {
                            my @pw = getpwnam($val);
                            push @uids, @pw ? $pw[2] : -1;
                        }
                    }
                    last COND unless _match($p->{euid}, \@uids, 1);
                }
            }

            $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__