Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

added ExternalCommandHelper role

  • Loading branch information...
commit 686aa7f536cc7a65b27e5cec19327a71f86b7756 1 parent d2fb884
@jberger authored
View
1  lib/Moodule/Build/Base.pm
@@ -7,6 +7,7 @@ use Moodule::Build::HashStore qw/HashStore/;
with 'Moodule::Build::Role::Logger';
with 'Moodule::Build::Role::Prompter';
+with 'Moodule::Build::Role::ExternalCommandHelper';
has 'dist_name' => (
is => 'ro',
View
208 lib/Moodule/Build/Role/ExternalCommandHelper.pm
@@ -0,0 +1,208 @@
+package Moodule::Build::Role::ExternalCommandHelper;
+
+use Moo::Role;
+
+use Cwd ();
+use File::Basename ();
+use File::Spec 0.82 ();
+use Module::Build::Config;
+
+requires 'log_warn';
+
+# Tells us whether the construct open($fh, '-|', @command) is
+# supported. It would probably be better to dynamically sense this.
+has 'have_forkpipe' => (
+ is => 'ro',
+ default => sub { 1 },
+);
+
+has 'perl' => (
+ is => 'ro',
+ builder => 1,
+);
+
+sub _build_perl {
+ my $self = shift;
+ # The following warning could be unnecessary if the user is running
+ # an embedded perl, but there aren't too many of those around, and
+ # embedded perls aren't usually used to install modules, and the
+ # installation process sometimes needs to run external scripts
+ # (e.g. to run tests).
+ $self->find_perl_interpreter
+ or $self->log_warn("Warning: Can't locate your perl binary");
+}
+
+sub _quote_args {
+ # Returns a string that can become [part of] a command line with
+ # proper quoting so that the subprocess sees this same list of args.
+ my ($self, @args) = @_;
+
+ my @quoted;
+
+ for (@args) {
+ if ( /^[^\s*?!\$<>;\\|'"\[\]\{\}]+$/ ) {
+ # Looks pretty safe
+ push @quoted, $_;
+ } else {
+ # XXX this will obviously have to improve - is there already a
+ # core module lying around that does proper quoting?
+ s/('+)/'"$1"'/g;
+ push @quoted, qq('$_');
+ }
+ }
+
+ return join " ", @quoted;
+}
+
+sub _backticks {
+ my ($self, @cmd) = @_;
+ if ($self->have_forkpipe) {
+ local *FH;
+ my $pid = open *FH, "-|";
+ if ($pid) {
+ return wantarray ? <FH> : join '', <FH>;
+ } else {
+ die "Can't execute @cmd: $!\n" unless defined $pid;
+ exec { $cmd[0] } @cmd;
+ }
+ } else {
+ my $cmd = $self->_quote_args(@cmd);
+ return `$cmd`;
+ }
+}
+
+# Determine whether a given binary is the same as the perl
+# (configuration) that started this process.
+sub _perl_is_same {
+ my ($self, $perl) = @_;
+
+ my @cmd = ($perl);
+
+ # 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.
+ if ($ENV{PERL_CORE}) {
+ push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib');
+ }
+
+ push @cmd, qw(-MConfig=myconfig -e print -e myconfig);
+ return $self->_backticks(@cmd) eq Config->myconfig;
+}
+
+# cache _discover_perl_interpreter() results
+{
+ my $known_perl;
+ sub find_perl_interpreter {
+ my $self = shift;
+
+ return $known_perl if defined($known_perl);
+ return $known_perl = $self->_discover_perl_interpreter;
+ }
+}
+
+# Returns the absolute path of the perl interpreter used to invoke
+# this process. The path is derived from $^X or $Config{perlpath}. On
+# some platforms $^X contains the complete absolute path of the
+# interpreter, on other it may contain a relative path, or simply
+# 'perl'. This can also vary depending on whether a path was supplied
+# when perl was invoked. Additionally, the value in $^X may omit the
+# executable extension on platforms that use one. It's a fatal error
+# if the interpreter can't be found because it can result in undefined
+# behavior by routines that depend on it (generating errors or
+# invoking the wrong perl.)
+sub _discover_perl_interpreter {
+ my $proto = shift;
+ my $c = ref($proto) && $proto->can('config') ? $proto->config : 'Module::Build::Config';
+
+ my $perl = $^X;
+ my $perl_basename = File::Basename::basename($perl);
+
+ my @potential_perls;
+
+ # Try 1, Check $^X for absolute path
+ push( @potential_perls, $perl )
+ if File::Spec->file_name_is_absolute($perl);
+
+ # Try 2, Check $^X for a valid relative path
+ my $abs_perl = File::Spec->rel2abs($perl);
+ push( @potential_perls, $abs_perl );
+
+ # Try 3, 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.
+
+ # CBuilder is also in the core, so it should be available here
+ require ExtUtils::CBuilder;
+ my $perl_src = Cwd::realpath( ExtUtils::CBuilder->perl_src );
+ if ( defined($perl_src) && length($perl_src) ) {
+ my $uninstperl =
+ File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename ));
+ push( @potential_perls, $uninstperl );
+ }
+
+ } else {
+
+ # Try 3.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, $c->get('perlpath') );
+
+ push( @potential_perls,
+ map File::Spec->catfile($_, $perl_basename), File::Spec->path() );
+ }
+
+ # 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 = $c->get('exe_ext');
+ foreach my $thisperl ( @potential_perls ) {
+
+ if (defined $exe) {
+ $thisperl .= $exe unless $thisperl =~ m/$exe$/i;
+ }
+
+ if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) {
+ return $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 File::Basename::dirname($_), @potential_perls;
+ die "Can't locate the perl binary used to run this script " .
+ "in (@paths)\n";
+}
+
+# Adapted from IPC::Cmd::can_run()
+sub find_command {
+ my ($self, $command) = @_;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return $self->_maybe_command($command);
+
+ } else {
+ for my $dir ( File::Spec->path ) {
+ my $abs = File::Spec->catfile($dir, $command);
+ return $abs if $abs = $self->_maybe_command($abs);
+ }
+ }
+}
+
+# Copied from ExtUtils::MM_Unix::maybe_command
+sub _maybe_command {
+ my($self,$file) = @_;
+ return $file if -x $file && ! -d $file;
+ return;
+}
+
+1;
+
Please sign in to comment.
Something went wrong with that request. Please try again.