File Coverage

blib/lib/Proc/Exists.pm

Criterion	Covered	Total	%
statement	24	24	100.0
branch	10	10	100.0
condition	7	7	100.0
subroutine	6	6	100.0
pod			n/a
total	47	47	100.0

package Proc::Exists;

use strict;
use Proc::Exists::Configuration;
use vars qw (@ISA @EXPORT_OK $VERSION);
eval { require warnings; }; #it's ok if we can't load warnings

require Exporter;
use base 'Exporter';
@EXPORT_OK = qw( pexists );
@ISA       = qw( Exporter );

$VERSION = '1.01';

my $use_pureperl = $Proc::Exists::Configuration::want_pureperl;
if(!$use_pureperl) {
	eval {
		require XSLoader;
		XSLoader::load('Proc::Exists', $VERSION);
		$Proc::Exists::_loader = 'XSLoader';
		1;
	} or eval {
		require DynaLoader;
		push @ISA, 'DynaLoader';
		bootstrap Proc::Exists $VERSION;
		$Proc::Exists::_loader = 'DynaLoader';
		1;
	} or do {
		#NOTE: don't need to worry about i18n, DynaLoader complains in english.
		#      (and XSLoader passes thru DynaLoader's complaints)
		if($@ =~ /Proc::Exists\s+object\s+version\s+\S+\s+does\s+not\s+match\s+bootstrap\s+parameter/ ) {
			warn "WARNING: it looks like you have a previous Proc::Exists ".
			     "version's object file(s) somewhere in \@INC! you will have ".
			     "to remove these and reinstall Proc::Exists. for now, we are ".
			     "falling back to pureperl, expect degraded performance: $@\n";
		} else {
			warn "WARNING: can't load XS. falling back to pureperl, ".
			     "expect degraded performance: $@\n";
		}
		$use_pureperl = 1;
	}
}

if($use_pureperl) {
	#warn "using pure perl mode, expect degraded performance\n";
	my $pp_pexists = sub {
		my @pids = @_;
		my %args = ref($pids[-1]) ? %{pop(@pids)} : ();

		die "can't specify both 'any' and 'all' arg" if($args{all} && $args{any});
		if(wantarray) {
			die "can't specify 'all' argument in list context" if($args{all});
			die "can't specify 'any' argument in list context" if($args{any});
		}

		my @results;
		foreach my $pid (@pids) {
			#ASSUMPTION: no systems allow a negative int as a PID
			if($pid !~ /^\d+$/) {
				if($pid =~ /^-\d+$/) {
					die "got negative pid: '$pid'";
				} elsif($pid =~ /^-?\d+\./) {
					die "got non-integer pid: '$pid'";
				} else {
					die "got non-number pid: '$pid'";
				}
			}

			my $ret;
			if (kill 0, $pid) {
				$ret = 1;
			} else {
				if($^O eq "MSWin32") {
					die "can't do pure perl on MSWin32 - \$!: (".(0+$!)."): $!";
        }
				if($!{EPERM}) {
					$ret = 1;
				} elsif($!{ESRCH}) {
					$ret = 0;
				} else {
					die "unknown numeric \$!: (".(0+$!)."): $!, pureperl, OS: $^O";
				}
			}

			if($ret) {
				return $pid if($args{any});
				push @results, $pid;
			} elsif($args{all}) {
				return 0;
			}
		}
		#NOTE: as documented in the pod, any returns undef for false,
		#      because some systems use pid==0
		return if($args{any});
		return wantarray ? @results : scalar @results;
	};
	*pexists = \&$pp_pexists;
	$Proc::Exists::pureperl = 1;

} else {

	my $xs_pexists = sub {
		my @pids = @_;
		my %args = ref($pids[-1]) ? %{pop(@pids)} : ();

		if(wantarray) {
			die "can't specify 'all' argument in list context" if($args{all});
			die "can't specify 'any' argument in list context" if($args{any});
			return _list_pexists([@pids]);
		} else {
			die "can't specify both 'any' and 'all' arg" if($args{all} && $args{any});
			return _scalar_pexists([@pids], $args{any} || 0, $args{all} || 0);
		}
	};
	*pexists = \&$xs_pexists;
	$Proc::Exists::pureperl = 0;

}

# !wantarray        : return number of matches
# !wantarray && any : return pid of first match if any match, else undef
# !wantarray && all : return a true value if all match, else a false value
#  wantarray        : return list of matching pids
#  wantarray && any : undefined, makes no sense
#   ALTERNATELY: could return list of size one with first matching pid,
#                else bare return
#  wantarray && all : undefined, makes no sense
#   ALTERNATELY: could return list of all pids on true, else bare return

1;
__END__