From 686aa7f536cc7a65b27e5cec19327a71f86b7756 Mon Sep 17 00:00:00 2001 From: Joel Berger Date: Thu, 15 Nov 2012 22:42:36 -0600 Subject: [PATCH] added ExternalCommandHelper role --- lib/Moodule/Build/Base.pm | 1 + .../Build/Role/ExternalCommandHelper.pm | 208 ++++++++++++++++++ 2 files changed, 209 insertions(+) create mode 100644 lib/Moodule/Build/Role/ExternalCommandHelper.pm diff --git a/lib/Moodule/Build/Base.pm b/lib/Moodule/Build/Base.pm index cf3f9fe..25c2562 100644 --- a/lib/Moodule/Build/Base.pm +++ b/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', diff --git a/lib/Moodule/Build/Role/ExternalCommandHelper.pm b/lib/Moodule/Build/Role/ExternalCommandHelper.pm new file mode 100644 index 0000000..e3e59ef --- /dev/null +++ b/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 ? : join '', ; + } 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; +