File Coverage

blib/lib/Devel/FindPerl.pm

Criterion	Covered	Total	%
statement	64	81	79.0
branch	8	24	33.3
condition	4	20	20.0
subroutine	15	16	93.7
pod	2	2	100.0
total	93	143	65.0

package Devel::FindPerl;
$Devel::FindPerl::VERSION = '0.016';
use strict;
use warnings;

use Exporter 5.57 'import';
our @EXPORT_OK = qw/find_perl_interpreter perl_is_same/;
our %EXPORT_TAGS = (all => \@EXPORT_OK);

use Carp q/carp/;
use Config;
use Cwd q/realpath/;
use File::Basename qw/basename dirname/;
use File::Spec::Functions qw/catfile catdir rel2abs file_name_is_absolute updir curdir path splitpath/;
use Scalar::Util 'tainted';
use IPC::Open2 qw/open2/;

my %perl_for;
sub find_perl_interpreter {
	my $config = shift || 'Devel::FindPerl::Config';
	my $key = $config->can('serialize') ? $config->serialize : '';
	$perl_for{$key} ||= _discover_perl_interpreter($config);
	return wantarray ? @{ $perl_for{$key} } : $perl_for{$key}[0];
}

sub _discover_perl_interpreter {
	my $config = shift;

	return VMS::Filespec::vmsify($^X) if $^O eq 'VMS';
	my $perl_basename = basename($^X);

	my @potential_perls;

	# Try 1, Check $^X for absolute and relative path
	push @potential_perls, file_name_is_absolute($^X) ? [ $^X ] : length +(splitpath($^X))[1] ? [ rel2abs($^X) ] : ();

	# Try 2, Last ditch effort: These two option use hackery to try to locate
	# a suitable perl. The hack varies depending on whether we are running
	# from an installed perl or an uninstalled perl in the perl source dist.
	if ($ENV{PERL_CORE}) {
		# Try 3.A, If we are in a perl source tree, running an uninstalled
		# perl, we can keep moving up the directory tree until we find our
		# binary. We wouldn't do this under any other circumstances.

		my $perl_src = _perl_src();
		if (defined($perl_src) && length($perl_src)) {
			my $uninstperl = catfile($perl_src, $perl_basename);
			# When run from the perl core, @INC will include the directories
			# where perl is yet to be installed. We need to reference the
			# absolute path within the source distribution where it can find
			# it's Config.pm This also prevents us from picking up a Config.pm
			# from a different configuration that happens to be already
			# installed in @INC.
			push @potential_perls, [ $uninstperl, '-I' . catdir($perl_src, 'lib') ];
		}
	}
	else {
		# Try 2.B, First look in $Config{perlpath}, then search the user's
		# PATH. We do not want to do either if we are running from an
		# uninstalled perl in a perl source tree.

		push @potential_perls, [ $config->get('perlpath') ];
		push @potential_perls, map { [ catfile($_, $perl_basename) ] } path();
	}
	@potential_perls = grep { !tainted($_->[0]) } @potential_perls;

	# Now that we've enumerated the potential perls, it's time to test
	# them to see if any of them match our configuration, returning the
	# absolute path of the first successful match.
	my $exe = $config->get('exe_ext');
	foreach my $thisperl (@potential_perls) {
		$thisperl->[0] .= $exe if length $exe and $thisperl->[0] !~ m/\Q$exe\E$/i;
		return $thisperl if -f $thisperl->[0] && perl_is_same(@{$thisperl});
	}

	# We've tried all alternatives, and didn't find a perl that matches
	# our configuration. Throw an exception, and list alternatives we tried.
	my @paths = map { dirname($_->[0]) } @potential_perls;
	die "Can't locate the perl binary used to run this script in (@paths)\n";
}

# if building perl, perl's main source directory
sub _perl_src {
	# N.B. makemaker actually searches regardless of PERL_CORE, but
	# only squawks at not finding it if PERL_CORE is set

	return unless $ENV{PERL_CORE};

	my $updir = updir;
	my $dir	 = curdir;

	# Try up to 10 levels upwards
	for (0..10) {
		if (
			-f catfile($dir,"config_h.SH")
			&&
			-f catfile($dir,"perl.h")
			&&
			-f catfile($dir,"lib","Exporter.pm")
		) {
			return realpath($dir);
		}

		$dir = catdir($dir, $updir);
	}

	carp "PERL_CORE is set but I can't find your perl source!\n";
	return;
}

sub perl_is_same {
	my @perl = @_;
	return lc _capture_command(@perl, qw(-MConfig=myconfig -e print -e myconfig)) eq lc Config->myconfig;
}

sub _capture_command {
	my (@command) = @_;

	local @ENV{qw/PATH IFS CDPATH ENV BASH_ENV/};
	delete @ENV{qw/PATH IFS CDPATH ENV BASH_ENV/};
	my $pid = open2(my($in, $out), @command);
	binmode $in, ':crlf' if $^O eq 'MSWin32';
	my $ret = do { local $/; <$in> };
	waitpid $pid, 0;
	return $ret;
}

sub Devel::FindPerl::Config::get {
	my ($self, $key) = @_;
	return $Config{$key};
}

1;

#ABSTRACT: Find the path to your perl

__END__