CPAN
view release on metacpan or search on metacpan
lib/CPAN/Distribution.pm view on Meta::CPAN
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Distribution;
use strict;
use Cwd qw(chdir);
use CPAN::Distroprefs;
use CPAN::InfoObj;
use File::Path ();
use POSIX ":sys_wait_h";
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
$VERSION = "2.34";
my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option
# no prepare, because prepare is not a command on the shell command line
# TODO: clear instance cache on reload
my %instance;
for my $method (qw(get make test install)) {
no strict 'refs';
for my $prefix (qw(pre post)) {
my $hookname = sprintf "%s_%s", $prefix, $method;
*$hookname = sub {
my($self) = @_;
for my $plugin (@{$CPAN::Config->{plugin_list}}) {
my($plugin_proper,$args) = split /=/, $plugin, 2;
$args = "" unless defined $args;
if ($CPAN::META->has_inst($plugin_proper)){
my @args = split /,/, $args;
$instance{$plugin} ||= $plugin_proper->new(@args);
if ($instance{$plugin}->can($hookname)) {
$instance{$plugin}->$hookname($self);
}
} else {
$CPAN::Frontend->mydie("Plugin '$plugin_proper' not found for hook '$hookname'");
}
}
};
}
}
# Accessors
sub cpan_comment {
my $self = shift;
my $ro = $self->ro or return;
$ro->{CPAN_COMMENT}
}
#-> CPAN::Distribution::undelay
sub undelay {
my $self = shift;
for my $delayer (
"configure_requires_later",
"configure_requires_later_for",
"later",
"later_for",
) {
delete $self->{$delayer};
}
}
#-> CPAN::Distribution::is_dot_dist
sub is_dot_dist {
my($self) = @_;
return substr($self->id,-1,1) eq ".";
}
lib/CPAN/Distribution.pm view on Meta::CPAN
if (exists $self->{cleanup_after_install_done}) {
if ($self->{force_update}) {
delete $self->{cleanup_after_install_done};
} else {
my $id = $self->{CALLED_FOR} || $self->pretty_id;
return $self->success(
"Has already been *installed and cleaned up in the staging area* within this session, will not work on it again; if you really want to start over, try something like `force get $id`"
);
}
}
if (my $why = $self->check_disabled) {
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
# XXX why is this goodbye() instead of just print/warn?
# Alternatively, should other print/warns here be goodbye()?
# -- xdg, 2012-04-05
return $self->goodbye("[disabled] -- NA $why");
}
$self->debug("checking already unwrapped[$self->{ID}]") if $CPAN::DEBUG;
if (exists $self->{build_dir} && -d $self->{build_dir}) {
# this deserves print, not warn:
return $self->success("Has already been unwrapped into directory ".
"$self->{build_dir}"
);
}
# XXX I'm not sure this should be here because it's not really
# a test for whether get should continue or return; this is
# a side effect -- xdg, 2012-04-05
$self->debug("checking missing build_dir[$self->{ID}]") if $CPAN::DEBUG;
if (exists $self->{build_dir} && ! -d $self->{build_dir}){
# we have lost it.
$self->fforce(""); # no method to reset all phases but not set force (dodge)
return undef; # no shortcut
}
# although we talk about 'force' we shall not test on
# force directly. New model of force tries to refrain from
# direct checking of force.
$self->debug("checking unwrapping error[$self->{ID}]") if $CPAN::DEBUG;
if ( exists $self->{unwrapped} and (
UNIVERSAL::can($self->{unwrapped},"failed") ?
$self->{unwrapped}->failed :
$self->{unwrapped} =~ /^NO/ )
) {
return $self->goodbye("Unwrapping had some problem, won't try again without force");
}
return undef; # no shortcut
}
#-> sub CPAN::Distribution::get ;
sub get {
my($self) = @_;
$self->pre_get();
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$self->post_get();
return $self->goto($goto);
}
if ( defined( my $sc = $self->shortcut_get) ) {
$self->post_get();
return $sc;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
# local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # get
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
my($local_file);
# XXX I don't think this check needs to be here, as it
# is already checked in shortcut_get() -- xdg, 2012-04-05
unless ($self->{build_dir} && -d $self->{build_dir}) {
$self->get_file_onto_local_disk;
if ($CPAN::Signal){
$self->post_get();
return;
}
$self->check_integrity;
if ($CPAN::Signal){
$self->post_get();
return;
}
(my $packagedir,$local_file) = $self->run_preps_on_packagedir;
# XXX why is this check here? -- xdg, 2012-04-08
if (exists $self->{writemakefile} && ref $self->{writemakefile}
&& $self->{writemakefile}->can("failed") &&
$self->{writemakefile}->failed) {
#
$self->post_get();
return;
}
$packagedir ||= $self->{build_dir};
$self->{build_dir} = $packagedir;
}
# XXX should this move up to after run_preps_on_packagedir?
# Otherwise, failing writemakefile can return without
# a $CPAN::Signal check -- xdg, 2012-04-05
if ($CPAN::Signal) {
$self->safe_chdir($sub_wd);
$self->post_get();
return;
}
unless ($self->patch){
$self->post_get();
return;
}
$self->store_persistent_state;
lib/CPAN/Distribution.pm view on Meta::CPAN
for my $k (sort keys %{$self->{configure_requires_later_for}||{}}) {
if ($self->{configure_requires_later_for}{$k}>1) {
my $type = "";
for my $p (@prereq) {
if ($p->[0] eq $k) {
$type = $p->[1];
}
}
$type = " $type" if $type;
$CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type");
sleep 1;
}
}
}
if ($prereq[0][0] eq "perl") {
my $need = "requires perl '$prereq[0][1]'";
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
$self->{make} = CPAN::Distrostatus->new("NO $need");
$self->store_persistent_state;
return $self->goodbye("[prereq] -- NOT OK");
} else {
my $follow = eval {
$self->follow_prereqs("configure_requires_later", @prereq);
};
if (0) {
} elsif ($follow) {
return; # we need deps
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
$CPAN::Frontend->mywarn($@);
return $self->goodbye("[depend] -- NOT OK");
}
else {
return $self->goodbye("[configure_requires] -- NOT OK");
}
}
die "never reached";
}
#-> sub CPAN::Distribution::choose_MM_or_MB ;
sub choose_MM_or_MB {
my($self) = @_;
$self->satisfy_configure_requires() or return;
my $local_file = $self->{localfile};
my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
my($mpl_exists) = -f $mpl;
unless ($mpl_exists) {
# NFS has been reported to have racing problems after the
# renaming of a directory in some environments.
# This trick helps.
$CPAN::Frontend->mysleep(1);
my $mpldh = DirHandle->new($self->{build_dir})
or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
$mpldh->close;
}
my $prefer_installer = "eumm"; # eumm|mb
if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
if ($mpl_exists) { # they *can* choose
if ($CPAN::META->has_inst("Module::Build")) {
$prefer_installer = CPAN::HandleConfig->prefs_lookup(
$self, q{prefer_installer}
);
# M::B <= 0.35 left a DATA handle open that
# causes problems upgrading M::B on Windows
close *Module::Build::Version::DATA
if fileno *Module::Build::Version::DATA;
}
} else {
$prefer_installer = "mb";
}
}
if (lc($prefer_installer) eq "rand") {
$prefer_installer = rand()<.5 ? "eumm" : "mb";
}
if (lc($prefer_installer) eq "mb") {
$self->{modulebuild} = 1;
} elsif ($self->{archived} eq "patch") {
# not an edge case, nothing to install for sure
my $why = "A patch file cannot be installed";
$CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
$self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
} elsif (! $mpl_exists) {
$self->_edge_cases($mpl,$local_file);
}
if ($self->{build_dir}
&&
$CPAN::Config->{build_dir_reuse}
) {
$self->store_persistent_state;
}
return $self;
}
# see also reanimate_build_dir
#-> CPAN::Distribution::store_persistent_state
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
unless (defined $dir && length $dir) {
my $id = $self->id;
$CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
"will not store persistent state\n");
return;
}
# self-build-dir
my $sbd = Cwd::realpath(
File::Spec->catdir($dir, File::Spec->updir ())
);
# config-build-dir
my $cbd = Cwd::realpath(
# the catdir is a workaround for bug https://rt.cpan.org/Ticket/Display.html?id=101283
File::Spec->catdir($CPAN::Config->{build_dir}, File::Spec->curdir())
);
unless ($sbd eq $cbd) {
$CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
"will not store persistent state\n");
return;
}
my $file = sprintf "%s.yml", $dir;
my $yaml_module = CPAN::_yaml_module();
if ($CPAN::META->has_inst($yaml_module)) {
CPAN->_yaml_dumpfile(
$file,
{
time => time,
perl => CPAN::_perl_fingerprint(),
distribution => $self,
}
);
} else {
$CPAN::Frontend->myprintonce("'$yaml_module' not installed, ".
"will not store persistent state\n");
}
}
#-> CPAN::Distribution::try_download
sub try_download {
my($self,$patch) = @_;
my $norm = $self->normalize($patch);
my($local_wanted) =
File::Spec->catfile(
$CPAN::Config->{keep_source_where},
"authors",
"id",
split(/\//,$norm),
);
$self->debug("Doing localize") if $CPAN::DEBUG;
return CPAN::FTP->localize("authors/id/$norm",
$local_wanted);
}
{
my $stdpatchargs = "";
#-> CPAN::Distribution::patch
sub patch {
my($self) = @_;
$self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
my $patches = $self->prefs->{patches};
$patches ||= "";
$self->debug("patches[$patches]") if $CPAN::DEBUG;
if ($patches) {
return unless @$patches;
$self->safe_chdir($self->{build_dir});
CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
my $patchbin = $CPAN::Config->{patch};
unless ($patchbin && length $patchbin) {
$CPAN::Frontend->mydie("No external patch command configured\n\n".
"Please run 'o conf init /patch/'\n\n");
}
unless (MM->maybe_command($patchbin)) {
$CPAN::Frontend->mydie("No external patch command available\n\n".
"Please run 'o conf init /patch/'\n\n");
}
$patchbin = CPAN::HandleConfig->safe_quote($patchbin);
local $ENV{PATCH_GET} = 0; # formerly known as -g0
unless ($stdpatchargs) {
my $system = "$patchbin --version |";
local *FH;
open FH, $system or die "Could not fork '$system': $!";
local $/ = "\n";
my $pversion;
PARSEVERSION: while (<FH>) {
if (/^patch\s+([\d\.]+)/) {
$pversion = $1;
last PARSEVERSION;
}
}
if ($pversion) {
$stdpatchargs = "-N --fuzz=3";
} else {
$stdpatchargs = "-N";
}
}
my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
$CPAN::Frontend->myprint("Applying $countedpatches:\n");
my $patches_dir = $CPAN::Config->{patches_dir};
for my $patch (@$patches) {
if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
my $f = File::Spec->catfile($patches_dir, $patch);
$patch = $f if -f $f;
}
unless (-f $patch) {
CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG;
if (my $trydl = $self->try_download($patch)) {
$patch = $trydl;
} else {
my $fail = "Could not find patch '$patch'";
$CPAN::Frontend->mywarn("$fail; cannot continue\n");
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
delete $self->{build_dir};
return;
}
}
$CPAN::Frontend->myprint(" $patch\n");
my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
my $pcommand;
my($ppp,$pfiles) = $self->_patch_p_parameter($readfh);
lib/CPAN/Distribution.pm view on Meta::CPAN
my($name, $prereq) = ("", "");
while (<$fh>) {
if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
if ($1 eq 'NAME') {
$state = "name";
} elsif ($1 eq 'PREREQUISITES') {
$state = "prereq";
}
} elsif ($state =~ m{^(name|prereq)$}) {
if (/^=/) {
$state = "poddir";
} elsif (/^\s*$/) {
# nop
} elsif ($state eq "name") {
if ($name eq "") {
($name) = /^(\S+)/;
$state = "poddir";
}
} elsif ($state eq "prereq") {
$prereq .= $_;
}
} elsif (/^=cut\b/) {
last;
}
}
$fh->close;
for ($name) {
s{.*<}{}; # strip X<...>
s{>.*}{};
}
chomp $prereq;
$prereq = join " ", split /\s+/, $prereq;
my($PREREQ_PM) = join("\n", map {
s{.*<}{}; # strip X<...>
s{>.*}{};
if (/[\s\'\"]/) { # prose?
} else {
s/[^\w:]$//; # period?
" "x28 . "'$_' => 0,";
}
} split /\s*,\s*/, $prereq);
if ($name) {
my $to_file = File::Spec->catfile($build_dir, $name);
rename $script_file, $to_file
or die "Can't rename $script_file to $to_file: $!";
}
return "
EXE_FILES => ['$name'],
PREREQ_PM => {
$PREREQ_PM
},
";
}
#-> CPAN::Distribution::_signature_business
sub _signature_business {
my($self) = @_;
my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
q{check_sigs});
if ($check_sigs) {
if ($CPAN::META->has_inst("Module::Signature")) {
if (-f "SIGNATURE") {
$self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
my $rv = Module::Signature::verify();
if ($rv != Module::Signature::SIGNATURE_OK() and
$rv != Module::Signature::SIGNATURE_MISSING()) {
$CPAN::Frontend->mywarn(
qq{\nSignature invalid for }.
qq{distribution file. }.
qq{Please investigate.\n\n}
);
my $wrap =
sprintf(qq{I'd recommend removing %s. Some error occurred }.
qq{while checking its signature, so it could }.
qq{be invalid. Maybe you have configured }.
qq{your 'urllist' with a bad URL. Please check this }.
qq{array with 'o conf urllist' and retry. Or }.
qq{examine the distribution in a subshell. Try
look %s
and run
cpansign -v
},
$self->{localfile},
$self->pretty_id,
);
$self->{signature_verify} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
$CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
} else {
$self->{signature_verify} = CPAN::Distrostatus->new("YES");
$self->debug("Module::Signature has verified") if $CPAN::DEBUG;
}
} else {
$CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
}
} else {
$self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
}
}
}
#-> CPAN::Distribution::untar_me ;
sub untar_me {
my($self,$ct) = @_;
$self->{archived} = "tar";
my $result = eval { $ct->untar() };
if ($result) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
# unfortunately we have no $@ here, Tarzip is using mydie which dies with "\n"
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
}
}
# CPAN::Distribution::unzip_me ;
sub unzip_me {
my($self,$ct) = @_;
lib/CPAN/Distribution.pm view on Meta::CPAN
return;
}
}
if ($self->CHECKSUM_check_file($lc_file)) {
return $self->{CHECKSUM_STATUS} = "OK";
}
}
#-> sub CPAN::Distribution::SIG_check_file ;
sub SIG_check_file {
my($self,$chk_file) = @_;
my $rv = eval { Module::Signature::_verify($chk_file) };
if ($rv eq Module::Signature::CANNOT_VERIFY()) {
$CPAN::Frontend->myprint(qq{\nSignature for }.
qq{file $chk_file could not be verified for an unknown reason. }.
$self->as_string.
qq{Module::Signature verification returned value $rv\n\n}
);
my $wrap = qq{The manual says for this case: Cannot verify the
OpenPGP signature, maybe due to the lack of a network connection to
the key server, or if neither gnupg nor Crypt::OpenPGP exists on the
system. You probably want to analyse the situation and if you cannot
fix it you will have to decide whether you want to stop this session
or you want to turn off signature verification. The latter would be
done with the command 'o conf init check_sigs'};
$CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
} if ($rv == Module::Signature::SIGNATURE_OK()) {
$CPAN::Frontend->myprint("Signature for $chk_file ok\n");
return $self->{SIG_STATUS} = "OK";
} else {
$CPAN::Frontend->mywarn(qq{\nSignature invalid for }.
qq{file $chk_file. }.
qq{Please investigate.\n\n}.
$self->as_string.
qq{Module::Signature verification returned value $rv\n\n}
);
my $wrap = qq{I\'d recommend removing $chk_file. Its signature
is invalid. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};
$CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
}
}
#-> sub CPAN::Distribution::CHECKSUM_check_file ;
# sloppy is 1 when we have an old checksums file that maybe is good
# enough
sub CHECKSUM_check_file {
my($self,$chk_file,$sloppy) = @_;
my($cksum,$file,$basename);
$sloppy ||= 0;
$self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
q{check_sigs});
if ($check_sigs) {
if ($CPAN::META->has_inst("Module::Signature")) {
$self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
$self->SIG_check_file($chk_file);
} else {
$self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
}
}
$file = $self->{localfile};
$basename = File::Basename::basename($file);
my($signed_data);
my $fh = FileHandle->new;
if ($check_sigs) {
my $tempdir;
if ($CPAN::META->has_usable("File::Temp")) {
$tempdir = File::Temp::tempdir("CHECKSUMS-XXXX", CLEANUP => 1, DIR => "/tmp" );
} else {
$tempdir = File::Spec->catdir(File::Spec->tmpdir, "CHECKSUMS-$$");
File::Path::mkpath($tempdir);
}
my $tempfile = File::Spec->catfile($tempdir, "CHECKSUMS.$$");
unlink $tempfile; # ignore missing file
my $devnull = File::Spec->devnull;
my $gpg = $CPAN::Config->{gpg} or
$CPAN::Frontend->mydie("Your configuration suggests that you do not have 'gpg' installed. This is needed to verify checksums with the config variable 'check_sigs' on. Please configure it with 'o conf init gpg'");
my $system = qq{"$gpg" --verify --batch --no-tty --output "$tempfile" "$chk_file" 2> "$devnull"};
0 == system $system or $CPAN::Frontend->mydie("gpg run was failing, cannot continue: $system");
open $fh, $tempfile or $CPAN::Frontend->mydie("Could not open $tempfile: $!");
local $/;
$signed_data = <$fh>;
close $fh;
File::Path::rmtree($tempdir);
} else {
my $fh = FileHandle->new;
if (open $fh, $chk_file) {
local($/);
$signed_data = <$fh>;
} else {
$CPAN::Frontend->mydie("Could not open $chk_file for reading");
}
close $fh;
}
$signed_data =~ s/\015?\012/\n/g;
my($compmt) = Safe->new();
$cksum = $compmt->reval($signed_data);
if ($@) {
rename $chk_file, "$chk_file.bad";
Carp::confess($@) if $@;
}
if (! ref $cksum or ref $cksum ne "HASH") {
$CPAN::Frontend->mywarn(qq{
Warning: checksum file '$chk_file' broken.
When trying to read that file I expected to get a hash reference
for further processing, but got garbage instead.
});
my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
lib/CPAN/Distribution.pm view on Meta::CPAN
The cause for this may be that the file is very new and the checksum
has not yet been calculated, but it may also be that something is
going awry right now.
});
my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
}
$self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
return;
}
}
#-> sub CPAN::Distribution::eq_CHECKSUM ;
sub eq_CHECKSUM {
my($self,$fh,$expect) = @_;
if ($CPAN::META->has_inst("Digest::SHA")) {
my $dg = Digest::SHA->new(256);
my($data);
while (read($fh, $data, 4096)) {
$dg->add($data);
}
my $hexdigest = $dg->hexdigest;
# warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
return $hexdigest eq $expect;
}
return 1;
}
#-> sub CPAN::Distribution::force ;
# Both CPAN::Modules and CPAN::Distributions know if "force" is in
# effect by autoinspection, not by inspecting a global variable. One
# of the reason why this was chosen to work that way was the treatment
# of dependencies. They should not automatically inherit the force
# status. But this has the downside that ^C and die() will return to
# the prompt but will not be able to reset the force_update
# attributes. We try to correct for it currently in the read_metadata
# routine, and immediately before we check for a Signal. I hope this
# works out in one of v1.57_53ff
# "Force get forgets previous error conditions"
#-> sub CPAN::Distribution::fforce ;
sub fforce {
my($self, $method) = @_;
$self->force($method,1);
}
#-> sub CPAN::Distribution::force ;
sub force {
my($self, $method,$fforce) = @_;
my %phase_map = (
get => [
"unwrapped",
"build_dir",
"archived",
"localfile",
"CHECKSUM_STATUS",
"signature_verify",
"prefs",
"prefs_file",
"prefs_file_doc",
"cleanup_after_install_done",
],
make => [
"writemakefile",
"make",
"modulebuild",
"prereq_pm",
"cleanup_after_install_done",
],
test => [
"badtestcnt",
"make_test",
"cleanup_after_install_done",
],
install => [
"install",
"cleanup_after_install_done",
],
unknown => [
"reqtype",
"yaml_content",
"cleanup_after_install_done",
],
);
my $methodmatch = 0;
my $ldebug = 0;
PHASE: for my $phase (qw(unknown get make test install)) { # order matters
$methodmatch = 1 if $fforce || ($method && $phase eq $method);
next unless $methodmatch;
ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
if ($phase eq "get") {
if (substr($self->id,-1,1) eq "."
&& $att =~ /(unwrapped|build_dir|archived)/ ) {
# cannot be undone for local distros
next ATTRIBUTE;
}
if ($att eq "build_dir"
&& $self->{build_dir}
&& $CPAN::META->{is_tested}
) {
delete $CPAN::META->{is_tested}{$self->{build_dir}};
}
} elsif ($phase eq "test") {
if ($att eq "make_test"
&& $self->{make_test}
&& $self->{make_test}{COMMANDID}
&& $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
) {
# endless loop too likely
next ATTRIBUTE;
}
}
delete $self->{$att};
if ($ldebug || $CPAN::DEBUG) {
# local $CPAN::DEBUG = 16; # Distribution
CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
}
}
}
if ($method && $method =~ /make|test|install/) {
lib/CPAN/Distribution.pm view on Meta::CPAN
}
sub prepare {
my ($self) = @_;
$self->get
or return;
if ( defined( my $sc = $self->shortcut_prepare) ) {
return $sc;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
local $ENV{PERL_USE_UNSAFE_INC} =
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $builddir = $self->dir or
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
return;
}
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL} || '';
local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL} || '';
$self->choose_MM_or_MB
or return;
my $configurator = $self->{configure} ? "Configure"
: $self->{modulebuild} ? "Build.PL"
: "Makefile.PL";
$CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
$ENV{PERL_AUTOINSTALL} ||= "--defaultdeps";
$ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
}
my $system;
my $pl_commandline;
if ($self->prefs->{pl}) {
$pl_commandline = $self->prefs->{pl}{commandline};
}
local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING} || '';
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
if ($pl_commandline) {
$system = $pl_commandline;
$ENV{PERL} = $^X;
} elsif ($self->{'configure'}) {
$system = $self->{'configure'};
} elsif ($self->{modulebuild}) {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
my $mbuildpl_arg = $self->_make_phase_arg("pl");
$system = sprintf("%s Build.PL%s",
$perl,
$mbuildpl_arg ? " $mbuildpl_arg" : "",
);
} else {
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
my $switch = "";
# This needs a handler that can be turned on or off:
# $switch = "-MExtUtils::MakeMaker ".
# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
# if $] > 5.00310;
my $makepl_arg = $self->_make_phase_arg("pl");
$ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
"Makefile.PL");
$system = sprintf("%s%s Makefile.PL%s",
$perl,
$switch ? " $switch" : "",
$makepl_arg ? " $makepl_arg" : "",
);
}
my $pl_env;
if ($self->prefs->{pl}) {
$pl_env = $self->prefs->{pl}{env};
}
local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
if (exists $self->{writemakefile}) {
} else {
local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
my($ret,$pid,$output);
$@ = "";
my $go_via_alarm;
if ($CPAN::Config->{inactivity_timeout}) {
require Config;
if ($Config::Config{d_alarm}
&&
$Config::Config{d_alarm} eq "define"
) {
$go_via_alarm++
} else {
$CPAN::Frontend->mywarn("Warning: you have configured the config ".
"variable 'inactivity_timeout' to ".
"'$CPAN::Config->{inactivity_timeout}'. But ".
"on this machine the system call 'alarm' ".
"isn't available. This means that we cannot ".
"provide the feature of intercepting long ".
"waiting code and will turn this feature off.\n"
);
$CPAN::Config->{inactivity_timeout} = 0;
}
}
if ($go_via_alarm) {
if ( $self->_should_report('pl') ) {
($output, $ret) = CPAN::Reporter::record_command(
$system,
$CPAN::Config->{inactivity_timeout},
);
CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
}
else {
eval {
alarm $CPAN::Config->{inactivity_timeout};
local $SIG{CHLD}; # = sub { wait };
if (defined($pid = fork)) {
if ($pid) { #parent
# wait;
waitpid $pid, 0;
} else { #child
# note, this exec isn't necessary if
# inactivity_timeout is 0. On the Mac I'd
# suggest, we set it always to 0.
exec $system;
}
} else {
$CPAN::Frontend->myprint("Cannot fork: $!");
return;
}
};
alarm 0;
if ($@) {
kill 9, $pid;
waitpid $pid, 0;
my $err = "$@";
$CPAN::Frontend->myprint($err);
$self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
$@ = "";
$self->store_persistent_state;
return $self->goodbye("$system -- TIMED OUT");
}
}
} else {
if (my $expect_model = $self->_prefs_with_expect("pl")) {
# XXX probably want to check _should_report here and warn
# about not being able to use CPAN::Reporter with expect
$ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
if (! defined $ret
&& $self->{writemakefile}
&& $self->{writemakefile}->failed) {
# timeout
return;
}
}
elsif ( $self->_should_report('pl') ) {
($output, $ret) = eval { CPAN::Reporter::record_command($system) };
if (! defined $output or $@) {
my $err = $@ || "Unknown error";
$CPAN::Frontend->mywarn("Error while running PL phase: $err\n");
$self->{writemakefile} = CPAN::Distrostatus
->new("NO '$system' returned status $ret and no output");
return $self->goodbye("$system -- NOT OK");
}
CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
}
else {
$ret = system($system);
}
if ($ret != 0) {
$self->{writemakefile} = CPAN::Distrostatus
->new("NO '$system' returned status $ret");
$CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
$self->store_persistent_state;
return $self->goodbye("$system -- NOT OK");
}
}
if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
delete $self->{make_clean}; # if cleaned before, enable next
$self->store_persistent_state;
return $self->success("$system -- OK");
} else {
my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
my $why = "No '$makefile' created";
$CPAN::Frontend->mywarn($why);
$self->{writemakefile} = CPAN::Distrostatus
->new(qq{NO -- $why\n});
$self->store_persistent_state;
return $self->goodbye("$system -- NOT OK");
}
}
$self->store_persistent_state;
return 1; # success
}
#-> sub CPAN::Distribution::shortcut_make ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_make {
my ($self) = @_;
$self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
if (defined $self->{make}) {
if (UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) {
if ($self->{force_update}) {
# Trying an already failed 'make' (unless somebody else blocks)
return undef; # no shortcut
} else {
# introduced for turning recursion detection into a distrostatus
my $error = length $self->{make}>3
? substr($self->{make},3) : "Unknown error";
$self->store_persistent_state;
return $self->goodbye("Could not make: $error\n");
}
} else {
return $self->success("Has already been made")
}
}
return undef; # no shortcut
}
#-> sub CPAN::Distribution::make ;
sub make {
my($self) = @_;
$self->pre_make();
if (exists $self->{cleanup_after_install_done}) {
$self->post_make();
return $self->get;
}
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$self->post_make();
return $self->goto($goto);
}
# Emergency brake if they said install Pippi and get newest perl
# XXX Would this make more sense in shortcut_prepare, since
# that doesn't make sense on a perl dist either? Broader
# question: what is the purpose of suggesting force install
# on a perl distribution? That seems unlikely to result in
# such a dependency being satisfied, even if the perl is
# successfully installed. This situation is tantamount to
# a prereq on a version of perl greater than the current one
# so I think we should just abort. -- xdg, 2012-04-06
if ($self->isa_perl) {
if (
$self->called_for ne $self->id &&
! $self->{force_update}
) {
# if we die here, we break bundles
$CPAN::Frontend
->mywarn(sprintf(
qq{The most recent version "%s" of the module "%s"
is part of the perl-%s distribution. To install that, you need to run
force install %s --or--
install %s
},
$CPAN::META->instance(
'CPAN::Module',
$self->called_for
)->cpan_version,
$self->called_for,
$self->isa_perl,
$self->called_for,
$self->pretty_id,
));
$self->{make} = CPAN::Distrostatus->new("NO isa perl");
$CPAN::Frontend->mysleep(1);
$self->post_make();
return;
}
}
unless ($self->prepare){
$self->post_make();
return;
}
if ( defined( my $sc = $self->shortcut_make) ) {
$self->post_make();
return $sc;
}
if ($CPAN::Signal) {
delete $self->{force_update};
$self->post_make();
return;
}
my $builddir = $self->dir or
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
$self->post_make();
return;
}
my $make = $self->{modulebuild} ? "Build" : "make";
$CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
local $ENV{PERL_USE_UNSAFE_INC} =
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
if ($CPAN::Signal) {
delete $self->{force_update};
$self->post_make();
return;
}
if ($^O eq 'MacOS') {
Mac::BuildTools::make($self);
$self->post_make();
return;
}
my %env;
while (my($k,$v) = each %ENV) {
next if defined $v;
$env{$k} = '';
}
local @ENV{keys %env} = values %env;
my $satisfied = eval { $self->satisfy_requires };
if ($@) {
return $self->goodbye($@);
}
unless ($satisfied){
$self->post_make();
return;
}
if ($CPAN::Signal) {
delete $self->{force_update};
$self->post_make();
return;
}
# need to chdir again, because $self->satisfy_requires might change the directory
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
$self->post_make();
return;
}
my $system;
my $make_commandline;
if ($self->prefs->{make}) {
$make_commandline = $self->prefs->{make}{commandline};
}
local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
if ($make_commandline) {
$system = $make_commandline;
$ENV{PERL} = CPAN::find_perl();
} else {
if ($self->{modulebuild}) {
unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
" in cwd[$cwd]. Danger, Will Robinson!\n");
$CPAN::Frontend->mysleep(5);
}
$system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
} else {
$system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
}
$system =~ s/\s+$//;
my $make_arg = $self->_make_phase_arg("make");
$system = sprintf("%s%s",
$system,
$make_arg ? " $make_arg" : "",
);
}
my $make_env;
if ($self->prefs->{make}) {
$make_env = $self->prefs->{make}{env};
}
local @ENV{keys %$make_env} = values %$make_env if $make_env;
my $expect_model = $self->_prefs_with_expect("make");
my $want_expect = 0;
if ( $expect_model && @{$expect_model->{talk}} ) {
my $can_expect = $CPAN::META->has_inst("Expect");
if ($can_expect) {
$want_expect = 1;
} else {
$CPAN::Frontend->mywarn("Expect not installed, falling back to ".
"system()\n");
}
}
my ($system_ok, $system_err);
if ($want_expect) {
# XXX probably want to check _should_report here and
# warn about not being able to use CPAN::Reporter with expect
$system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
}
elsif ( $self->_should_report('make') ) {
my ($output, $ret) = CPAN::Reporter::record_command($system);
CPAN::Reporter::grade_make( $self, $system, $output, $ret );
$system_ok = ! $ret;
}
else {
my $rc = system($system);
$system_ok = $rc == 0;
$system_err = $! if $rc == -1;
}
$self->introduce_myself;
if ( $system_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$self->{make} = CPAN::Distrostatus->new("YES");
} else {
$self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
$self->{make} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
$CPAN::Frontend->mywarn(" $system_err\n") if defined $system_err;
}
$self->store_persistent_state;
$self->post_make();
return !! $system_ok;
}
# CPAN::Distribution::goodbye ;
sub goodbye {
my($self,$goodbye) = @_;
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn(" $id\n $goodbye\n");
return 0; # must be explicit false, not undef
}
sub success {
my($self,$why) = @_;
my $id = $self->pretty_id;
$CPAN::Frontend->myprint(" $id\n $why\n");
return 1;
}
# CPAN::Distribution::_run_via_expect ;
sub _run_via_expect {
lib/CPAN/Distribution.pm view on Meta::CPAN
my $have_waited = time - $timeout_start;
if ($have_waited < $timeout) {
# warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
next EXPECT;
}
my $why = "could not answer a question during the dialog";
$CPAN::Frontend->mywarn("Failing: $why\n");
$self->{$phase} =
CPAN::Distrostatus->new("NO $why");
return 0;
}
}
}
sub _run_via_expect_deterministic {
my($self,$expo,$phase,$expect_model) = @_;
my $ran_into_timeout;
my $ran_into_eof;
my $timeout = $expect_model->{timeout} || 15; # currently unsettable
my $expecta = $expect_model->{talk};
EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
my($re,$send) = @$expecta[$i,$i+1];
CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
my $regex = eval "qr{$re}";
$expo->expect($timeout,
[ eof => sub {
my $but = $expo->clear_accum;
$CPAN::Frontend->mywarn("EOF (maybe harmless)
expected[$regex]\nbut[$but]\n\n");
$ran_into_eof++;
} ],
[ timeout => sub {
my $but = $expo->clear_accum;
$CPAN::Frontend->mywarn("TIMEOUT
expected[$regex]\nbut[$but]\n\n");
$ran_into_timeout++;
} ],
-re => $regex);
if ($ran_into_timeout) {
# note that the caller expects 0 for success
$self->{$phase} =
CPAN::Distrostatus->new("NO timeout during expect dialog");
return 0;
} elsif ($ran_into_eof) {
last EXPECT;
}
$expo->send($send);
}
$expo->soft_close;
return $expo->exitstatus();
}
#-> CPAN::Distribution::_validate_distropref
sub _validate_distropref {
my($self,@args) = @_;
if (
$CPAN::META->has_inst("CPAN::Kwalify")
&&
$CPAN::META->has_inst("Kwalify")
) {
eval {CPAN::Kwalify::_validate("distroprefs",@args);};
if ($@) {
$CPAN::Frontend->mywarn($@);
}
} else {
CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
}
}
#-> CPAN::Distribution::_find_prefs
sub _find_prefs {
my($self) = @_;
my $distroid = $self->pretty_id;
#CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
my $prefs_dir = $CPAN::Config->{prefs_dir};
return if $prefs_dir =~ /^\s*$/;
eval { File::Path::mkpath($prefs_dir); };
if ($@) {
$CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
}
# shortcut if there are no distroprefs files
{
my $dh = DirHandle->new($prefs_dir) or $CPAN::Frontend->mydie("Couldn't open '$prefs_dir': $!");
my @files = map { /\.(yml|dd|st)\z/i } $dh->read;
return unless @files;
}
my $yaml_module = CPAN::_yaml_module();
my $ext_map = {};
my @extensions;
if ($CPAN::META->has_inst($yaml_module)) {
$ext_map->{yml} = 'CPAN';
} else {
my @fallbacks;
if ($CPAN::META->has_inst("Data::Dumper")) {
push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
}
if ($CPAN::META->has_inst("Storable")) {
push @fallbacks, $ext_map->{st} = 'Storable';
}
if (@fallbacks) {
local $" = " and ";
unless ($self->{have_complained_about_missing_yaml}++) {
$CPAN::Frontend->mywarnonce("'$yaml_module' not installed, falling back ".
"to @fallbacks to read prefs '$prefs_dir'\n");
}
} else {
unless ($self->{have_complained_about_missing_yaml}++) {
$CPAN::Frontend->mywarnonce("'$yaml_module' not installed, cannot ".
"read prefs '$prefs_dir'\n");
}
}
}
my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
DIRENT: while (my $result = $finder->next) {
if ($result->is_warning) {
$CPAN::Frontend->mywarn($result->as_string);
$CPAN::Frontend->mysleep(1);
next DIRENT;
} elsif ($result->is_fatal) {
$CPAN::Frontend->mydie($result->as_string);
}
my @prefs = @{ $result->prefs };
ELEMENT: for my $y (0..$#prefs) {
my $pref = $prefs[$y];
$self->_validate_distropref($pref->data, $result->abs, $y);
# I don't know why we silently skip when there's no match, but
# complain if there's an empty match hashref, and there's no
# comment explaining why -- hdp, 2008-03-18
unless ($pref->has_any_match) {
next ELEMENT;
}
unless ($pref->has_valid_subkeys) {
$CPAN::Frontend->mydie(sprintf
"Nonconforming .%s file '%s': " .
"missing match/* subattribute. " .
"Please remove, cannot continue.",
$result->ext, $result->abs,
);
}
my $arg = {
env => \%ENV,
distribution => $distroid,
perl => \&CPAN::find_perl,
perlconfig => \%Config::Config,
module => sub { [ $self->containsmods ] },
};
if ($pref->matches($arg)) {
return {
prefs => $pref->data,
prefs_file => $result->abs,
prefs_file_doc => $y,
};
}
}
}
return;
}
# CPAN::Distribution::prefs
sub prefs {
my($self) = @_;
if (exists $self->{negative_prefs_cache}
&&
$self->{negative_prefs_cache} != $CPAN::CurrentCommandId
) {
delete $self->{negative_prefs_cache};
delete $self->{prefs};
}
if (exists $self->{prefs}) {
return $self->{prefs}; # XXX comment out during debugging
}
if ($CPAN::Config->{prefs_dir}) {
CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
my $prefs = $self->_find_prefs();
$prefs ||= ""; # avoid warning next line
CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
if ($prefs) {
for my $x (qw(prefs prefs_file prefs_file_doc)) {
$self->{$x} = $prefs->{$x};
}
my $bs = sprintf(
"%s[%s]",
File::Basename::basename($self->{prefs_file}),
$self->{prefs_file_doc},
);
my $filler1 = "_" x 22;
my $filler2 = int(66 - length($bs))/2;
$filler2 = 0 if $filler2 < 0;
$filler2 = " " x $filler2;
$CPAN::Frontend->myprint("
$filler1 D i s t r o P r e f s $filler1
$filler2 $bs $filler2
");
$CPAN::Frontend->mysleep(1);
return $self->{prefs};
}
}
$self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
return $self->{prefs} = +{};
}
# CPAN::Distribution::_make_phase_arg
sub _make_phase_arg {
my($self, $phase) = @_;
my $_make_phase_arg;
my $prefs = $self->prefs;
if (
$prefs
&& exists $prefs->{$phase}
&& exists $prefs->{$phase}{args}
&& $prefs->{$phase}{args}
) {
$_make_phase_arg = join(" ",
map {CPAN::HandleConfig
->safe_quote($_)} @{$prefs->{$phase}{args}},
);
}
# cpan[2]> o conf make[TAB]
# make make_install_make_command
# make_arg makepl_arg
# make_install_arg
# cpan[2]> o conf mbuild[TAB]
# mbuild_arg mbuild_install_build_command
# mbuild_install_arg mbuildpl_arg
my $mantra; # must switch make/mbuild here
if ($self->{modulebuild}) {
$mantra = "mbuild";
} else {
$mantra = "make";
}
my %map = (
pl => "pl_arg",
make => "_arg",
test => "_test_arg", # does not really exist but maybe
# will some day and now protects
# us from unini warnings
install => "_install_arg",
);
my $phase_underscore_meshup = $map{$phase};
my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;
$_make_phase_arg ||= $CPAN::Config->{$what};
return $_make_phase_arg;
}
# CPAN::Distribution::_make_command
sub _make_command {
my ($self) = @_;
if ($self) {
return
CPAN::HandleConfig
->safe_quote(
CPAN::HandleConfig->prefs_lookup($self,
q{make})
|| $Config::Config{make}
|| 'make'
);
} else {
# Old style call, without object. Deprecated
Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
return
safe_quote(undef,
CPAN::HandleConfig->prefs_lookup($self,q{make})
|| $CPAN::Config->{make}
|| $Config::Config{make}
|| 'make');
}
}
sub _make_install_make_command {
my ($self) = @_;
my $mimc =
CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
return $self->_make_command() unless $mimc;
# Quote the "make install" make command on Windows, where it is commonly
# found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
# do this in general because the command maybe "sudo make..." (i.e. a
# program with arguments), but that is unlikely to be the case on Windows.
$mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';
return $mimc;
}
#-> sub CPAN::Distribution::is_locally_optional
sub is_locally_optional {
my($self, $prereq_pm, $prereq) = @_;
$prereq_pm ||= $self->{prereq_pm};
my($nmo,$opt);
for my $rt (qw(requires build_requires)) {
if (exists $prereq_pm->{$rt}{$prereq}) {
# rt 121914
$nmo ||= $CPAN::META->instance("CPAN::Module",$prereq);
my $av = $nmo->available_version;
return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq});
}
if (exists $prereq_pm->{"opt_$rt"}{$prereq}) {
$opt = 1;
}
}
return $opt||0;
}
#-> sub CPAN::Distribution::follow_prereqs ;
sub follow_prereqs {
my($self) = shift;
my($slot) = shift;
my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
return unless @prereq_tuples;
my(@good_prereq_tuples);
for my $p (@prereq_tuples) {
# e.g. $p = ['Devel::PartialDump', 'r', 1]
# promote if possible
if ($p->[1] =~ /^(r|c)$/) {
push @good_prereq_tuples, $p;
} elsif ($p->[1] =~ /^(b)$/) {
my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
if ($reqtype =~ /^(r|c)$/) {
push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
} else {
push @good_prereq_tuples, $p;
}
} else {
die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
}
}
my $pretty_id = $self->pretty_id;
my %map = (
b => "build_requires",
r => "requires",
c => "commandline",
);
my($filler1,$filler2,$filler3,$filler4);
lib/CPAN/Distribution.pm view on Meta::CPAN
my $answer = CPAN::Shell::colorable_makemaker_prompt(
"Shall I follow them and prepend them to the queue
of modules we are processing right now?", "yes");
$follow = $answer =~ /^\s*y/i;
} else {
my @prereq = map { $_->[0] } @good_prereq_tuples;
local($") = ", ";
$CPAN::Frontend->
myprint(" Ignoring dependencies on modules @prereq\n");
}
if ($follow) {
my $id = $self->id;
my(@to_queue_mand,@to_queue_opt);
for my $gp (@good_prereq_tuples) {
my($prereq,$reqtype,$optional) = @$gp;
my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
if ($optional &&
$self->is_locally_optional(undef,$prereq)
){
# Since we do not depend on this one, we do not need
# this in a mandatory arrangement:
push @to_queue_opt, $qthing;
} else {
my $any = CPAN::Shell->expandany($prereq);
$self->{$slot . "_for"}{$any->id}++;
if ($any) {
unless ($optional) {
# No recursion check in an optional area of the tree
$any->color_cmd_tmps(0,2);
}
} else {
$CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
$CPAN::Frontend->mysleep(2);
}
# order everything that is not locally_optional just
# like mandatory items: this keeps leaves before
# branches
unshift @to_queue_mand, $qthing;
}
}
if (@to_queue_mand) {
unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
$self->{$slot} = "Delayed until after prerequisites";
return 1; # signal we need dependencies
} elsif (@to_queue_opt) {
CPAN::Queue->jumpqueue(@to_queue_opt);
}
}
return;
}
sub _feature_depends {
my($self) = @_;
my $meta_yml = $self->parse_meta_yml();
my $optf = $meta_yml->{optional_features} or return;
if (!ref $optf or ref $optf ne "HASH"){
$CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
$optf = {};
}
my $wantf = $self->prefs->{features} or return;
if (!ref $wantf or ref $wantf ne "ARRAY"){
$CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
$wantf = [];
}
my $dep = +{};
for my $wf (@$wantf) {
if (my $f = $optf->{$wf}) {
$CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
"is accompanied by this description:\n".
$f->{description}.
"\n\n"
);
# configure_requires currently not in the spec, unlikely to be useful anyway
for my $reqtype (qw(configure_requires build_requires requires)) {
my $reqhash = $f->{$reqtype} or next;
while (my($k,$v) = each %$reqhash) {
$dep->{$reqtype}{$k} = $v;
}
}
} else {
$CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
"found in the META.yml file".
"\n\n"
);
}
}
$dep;
}
sub prereqs_for_slot {
my($self,$slot) = @_;
my($prereq_pm);
unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
my $whynot = "not available";
if (defined $CPAN::Meta::Requirements::VERSION) {
$whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient";
}
$CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n");
my $before = "";
if ($self->{CALLED_FOR}){
if ($self->{CALLED_FOR} =~
/^(
CPAN::Meta::Requirements
|CPAN::DistnameInfo
|version
|parent
|ExtUtils::MakeMaker
|Test::Harness
)$/x) {
$CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ".
"as soon as possible; it is needed for a reliable operation of ".
"the cpan shell; setting requirements to nil for '$1' for now ".
"to prevent deadlock during bootstrapping\n");
return;
}
$before = " before $self->{CALLED_FOR}";
}
$CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before");
}
my $merged = CPAN::Meta::Requirements->new;
my $prefs_depends = $self->prefs->{depends}||{};
my $feature_depends = $self->_feature_depends();
if ($slot eq "configure_requires_later") {
for my $hash ( $self->configure_requires,
$prefs_depends->{configure_requires},
$feature_depends->{configure_requires},
) {
$merged->add_requirements(
CPAN::Meta::Requirements->from_string_hash($hash)
);
}
if (-f "Build.PL"
&& ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
&& ! @{[ $merged->required_modules ]}
&& ! $CPAN::META->has_inst("Module::Build")
) {
$CPAN::Frontend->mywarn(
" Warning: CPAN.pm discovered Module::Build as undeclared prerequisite.\n".
" Adding it now as such.\n"
);
$CPAN::Frontend->mysleep(5);
$merged->add_minimum( "Module::Build" => 0 );
delete $self->{writemakefile};
}
$prereq_pm = {}; # configure_requires defined as "b"
} elsif ($slot eq "later") {
my $prereq_pm_0 = $self->prereq_pm || {};
for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
$prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
for my $dep ($prefs_depends,$feature_depends) {
for my $k (keys %{$dep->{$reqtype}||{}}) {
$prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
}
}
}
# XXX what about optional_req|breq? -- xdg, 2012-04-01
for my $hash (
$prereq_pm->{requires},
$prereq_pm->{build_requires},
$prereq_pm->{opt_requires},
$prereq_pm->{opt_build_requires},
) {
$merged->add_requirements(
CPAN::Meta::Requirements->from_string_hash($hash)
);
}
} else {
die "Panic: illegal slot '$slot'";
}
return ($merged->as_string_hash, $prereq_pm);
}
#-> sub CPAN::Distribution::unsat_prereq ;
# return ([Foo,"r"],[Bar,"b"]) for normal modules
# return ([perl=>5.008]) if we need a newer perl than we are running under
# (sorry for the inconsistency, it was an accident)
sub unsat_prereq {
my($self,$slot) = @_;
my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
my(@need);
unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
$CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n");
return;
}
my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
my @merged = sort $merged->required_modules;
CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
NEED: for my $need_module ( @merged ) {
my $need_version = $merged->requirements_for_module($need_module);
my($available_version,$inst_file,$available_file,$nmo);
if ($need_module eq "perl") {
$available_version = $];
$available_file = CPAN::find_perl();
} else {
if (CPAN::_sqlite_running()) {
CPAN::Index->reload;
$CPAN::SQLite->search("CPAN::Module",$need_module);
}
$nmo = $CPAN::META->instance("CPAN::Module",$need_module);
$inst_file = $nmo->inst_file || '';
$available_file = $nmo->available_file || '';
$available_version = $nmo->available_version;
if ($nmo->uptodate) {
my $accepts = eval {
$merged->accepts_module($need_module, $available_version);
};
unless ($accepts) {
my $rq = $merged->requirements_for_module( $need_module );
$CPAN::Frontend->mywarn(
lib/CPAN/Distribution.pm view on Meta::CPAN
my $makefile = File::Spec->catfile($build_dir,"Makefile");
my $fh;
my @exe_files;
if (-f $makefile
and
$fh = FileHandle->new("<$makefile\0")) {
CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
local($/) = "\n";
while (<$fh>) {
last if /MakeMaker post_initialize section/;
my($p) = m{^[\#]
\s+EXE_FILES\s+=>\s+\[(.+)\]
}x;
next unless $p;
# warn "Found exefiles expr[$p]";
my @p = split /,\s*/, $p;
for my $p2 (@p) {
if ($p2 =~ /^q\[(.+)\]/) {
push @exe_files, $1;
}
}
}
}
return \@exe_files if @exe_files;
my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
if (-f $buildparams) {
CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
my $x = do $buildparams;
for my $sf ($x->[2]{script_files}) {
if (my $reftype = ref $sf) {
if ($reftype eq "ARRAY") {
push @exe_files, @$sf;
}
elsif ($reftype eq "HASH") {
push @exe_files, keys %$sf;
}
else {
$CPAN::Frontend->mywarn("Invalid reftype $reftype for Build.PL 'script_files'\n");
}
}
elsif (defined $sf) {
push @exe_files, $sf;
}
}
}
return \@exe_files;
}
#-> sub CPAN::Distribution::test ;
sub test {
my($self) = @_;
$self->pre_test();
if (exists $self->{cleanup_after_install_done}) {
$self->post_test();
return $self->make;
}
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$self->post_test();
return $self->goto($goto);
}
unless ($self->make){
$self->post_test();
return;
}
if ( defined( my $sc = $self->shortcut_test ) ) {
$self->post_test();
return $sc;
}
if ($CPAN::Signal) {
delete $self->{force_update};
$self->post_test();
return;
}
# warn "XDEBUG: checking for notest: $self->{notest} $self";
my $make = $self->{modulebuild} ? "Build" : "make";
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
local $ENV{PERL_USE_UNSAFE_INC} =
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
if ($run_allow_installing_within_test) {
my($allow_installing, $why) = $self->_allow_installing;
if (! $allow_installing) {
$CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n");
$self->introduce_myself;
$self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why");
$CPAN::Frontend->mywarn(" [testing] -- NOT OK\n");
delete $self->{force_update};
$self->post_test();
return;
}
}
$CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id);
my $builddir = $self->dir or
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
$self->post_test();
return;
}
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
$self->post_test();
return;
}
if ($self->{modulebuild}) {
my $thm = CPAN::Shell->expand("Module","Test::Harness");
my $v = $thm->inst_version;
if (CPAN::Version->vlt($v,2.62)) {
# XXX Eric Wilhelm reported this as a bug: klapperl:
# Test::Harness 3.0 self-tests, so that should be 'unless
# installing Test::Harness'
unless ($self->id eq $thm->distribution->id) {
$CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
'$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
$self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
$self->post_test();
return;
}
}
}
if ( ! $self->{force_update} ) {
# bypass actual tests if "trust_test_report_history" and have a report
my $have_tested_fcn;
if ( $CPAN::Config->{trust_test_report_history}
&& $CPAN::META->has_inst("CPAN::Reporter::History")
&& ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
# Do nothing if grade was DISCARD
if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
$self->{make_test} = CPAN::Distrostatus->new("YES");
# if global "is_tested" has been cleared, we need to mark this to
# be added to PERL5LIB if not already installed
if ($self->tested_ok_but_not_installed) {
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
}
$CPAN::Frontend->myprint("Found prior test report -- OK\n");
$self->post_test();
return;
}
elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
$self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
$self->post_test();
return;
}
}
}
}
my $system;
my $prefs_test = $self->prefs->{test};
if (my $commandline
= exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
$system = $commandline;
$ENV{PERL} = CPAN::find_perl();
} elsif ($self->{modulebuild}) {
$system = sprintf "%s test", $self->_build_command();
unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
}
} else {
$system = join " ", $self->_make_command(), "test";
}
my $make_test_arg = $self->_make_phase_arg("test");
$system = sprintf("%s%s",
$system,
$make_test_arg ? " $make_test_arg" : "",
);
my($tests_ok);
my $test_env;
if ($self->prefs->{test}) {
$test_env = $self->prefs->{test}{env};
}
local @ENV{keys %$test_env} = values %$test_env if $test_env;
my $expect_model = $self->_prefs_with_expect("test");
my $want_expect = 0;
if ( $expect_model && @{$expect_model->{talk}} ) {
my $can_expect = $CPAN::META->has_inst("Expect");
if ($can_expect) {
$want_expect = 1;
} else {
$CPAN::Frontend->mywarn("Expect not installed, falling back to ".
"testing without\n");
}
}
FORK: {
my $pid = fork;
if (! defined $pid) { # contention
warn "Contention '$!', sleeping 2";
sleep 2;
redo FORK;
} elsif ($pid) { # parent
if ($^O eq "MSWin32") {
wait;
} else {
SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
if ($CPAN::Signal) {
kill 9, -$pid;
}
sleep 1;
}
}
$tests_ok = !$?;
} else { # child
POSIX::setsid() unless $^O eq "MSWin32";
my $c_ok;
$|=1;
if ($want_expect) {
if ($self->_should_report('test')) {
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
"not supported when distroprefs specify ".
"an interactive test\n");
}
$c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
} elsif ( $self->_should_report('test') ) {
$c_ok = CPAN::Reporter::test($self, $system);
} else {
$c_ok = system($system) == 0;
}
exit !$c_ok;
}
} # FORK
$self->introduce_myself;
my $but = $self->_make_test_illuminate_prereqs();
if ( $tests_ok ) {
if ($but) {
$CPAN::Frontend->mywarn("Tests succeeded but $but\n");
$self->{make_test} = CPAN::Distrostatus->new("NO $but");
$self->store_persistent_state;
$self->post_test();
return $self->goodbye("[dependencies] -- NA");
}
$CPAN::Frontend->myprint(" $system -- OK\n");
$self->{make_test} = CPAN::Distrostatus->new("YES");
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
# probably impossible to need the next line because badtestcnt
# has a lifespan of one command
delete $self->{badtestcnt};
} else {
if ($but) {
$but .= "; additionally test harness failed";
$CPAN::Frontend->mywarn("$but\n");
$self->{make_test} = CPAN::Distrostatus->new("NO $but");
} elsif ( $self->{force_update} ) {
$self->{make_test} = CPAN::Distrostatus->new(
"NO but failure ignored because 'force' in effect"
);
} elsif ($CPAN::Signal) {
$self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted");
} else {
$self->{make_test} = CPAN::Distrostatus->new("NO");
}
$self->{badtestcnt}++;
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
CPAN::Shell->optprint
("hint",
sprintf
("//hint// to see the cpan-testers results for installing this module, try:
reports %s\n",
$self->pretty_id));
}
$self->store_persistent_state;
$self->post_test();
return $self->{force_update} ? 1 : !! $tests_ok;
}
sub _make_test_illuminate_prereqs {
my($self) = @_;
my @prereq;
# local $CPAN::DEBUG = 16; # Distribution
for my $m (sort keys %{$self->{sponsored_mods}}) {
next unless $self->{sponsored_mods}{$m} > 0;
my $m_obj = CPAN::Shell->expand("Module",$m) or next;
# XXX we need available_version which reflects
# $ENV{PERL5LIB} so that already tested but not yet
# installed modules are counted.
my $available_version = $m_obj->available_version;
my $available_file = $m_obj->available_file;
if ($available_version &&
!CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
) {
CPAN->debug("m[$m] good enough available_version[$available_version]")
if $CPAN::DEBUG;
} elsif ($available_file
&& (
!$self->{prereq_pm}{$m}
||
$self->{prereq_pm}{$m} == 0
)
) {
# lex Class::Accessor::Chained::Fast which has no $VERSION
CPAN->debug("m[$m] have available_file[$available_file]")
if $CPAN::DEBUG;
} else {
push @prereq, $m
unless $self->is_locally_optional(undef, $m);
}
}
my $but;
if (@prereq) {
my $cnt = @prereq;
my $which = join ",", @prereq;
$but = $cnt == 1 ? "one dependency not OK ($which)" :
"$cnt dependencies missing ($which)";
}
$but;
}
sub _prefs_with_expect {
my($self,$where) = @_;
return unless my $prefs = $self->prefs;
return unless my $where_prefs = $prefs->{$where};
if ($where_prefs->{expect}) {
return {
mode => "deterministic",
timeout => 15,
talk => $where_prefs->{expect},
};
} elsif ($where_prefs->{"eexpect"}) {
return $where_prefs->{"eexpect"};
}
return;
}
#-> sub CPAN::Distribution::clean ;
sub clean {
my($self) = @_;
my $make = $self->{modulebuild} ? "Build" : "make";
$CPAN::Frontend->myprint(sprintf "Running %s clean for %s\n", $make, $self->pretty_id);
unless (exists $self->{archived}) {
$CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
"/untarred, nothing done\n");
return 1;
}
unless (exists $self->{build_dir}) {
$CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
return 1;
}
if (exists $self->{writemakefile}
and $self->{writemakefile}->failed
) {
$CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
return 1;
}
EXCUSE: {
my @e;
exists $self->{make_clean} and $self->{make_clean} eq "YES" and
push @e, "make clean already called once";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
chdir "$self->{build_dir}" or
Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
$self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_clean($self);
return;
}
my $system;
if ($self->{modulebuild}) {
unless (-f "Build") {
my $cwd = CPAN::anycwd();
$CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
" in cwd[$cwd]. Danger, Will Robinson!");
$CPAN::Frontend->mysleep(5);
}
$system = sprintf "%s clean", $self->_build_command();
} else {
$system = join " ", $self->_make_command(), "clean";
}
my $system_ok = system($system) == 0;
$self->introduce_myself;
if ( $system_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
# $self->force;
# Jost Krieger pointed out that this "force" was wrong because
# it has the effect that the next "install" on this distribution
# will untar everything again. Instead we should bring the
# object's state back to where it is after untarring.
for my $k (qw(
force_update
install
writemakefile
make
make_test
)) {
delete $self->{$k};
}
$self->{make_clean} = CPAN::Distrostatus->new("YES");
} else {
# Hmmm, what to do if make clean failed?
$self->{make_clean} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
# 2006-02-27: seems silly to me to force a make now
# $self->force("make"); # so that this directory won't be used again
}
$self->store_persistent_state;
}
#-> sub CPAN::Distribution::check_disabled ;
sub check_disabled {
my ($self) = @_;
$self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
if ($self->prefs->{disabled} && ! $self->{force_update}) {
return sprintf(
"Disabled via prefs file '%s' doc %d",
$self->{prefs_file},
$self->{prefs_file_doc},
);
}
return;
}
#-> sub CPAN::Distribution::goto ;
sub goto {
my($self,$goto) = @_;
$goto = $self->normalize($goto);
my $why = sprintf(
"Goto '$goto' via prefs file '%s' doc %d",
$self->{prefs_file},
$self->{prefs_file_doc},
);
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
# 2007-07-16 akoenig : Better than NA would be if we could inherit
# the status of the $goto distro but given the exceptional nature
# of 'goto' I feel reluctant to implement it
my $goodbye_message = "[goto] -- NA $why";
$self->goodbye($goodbye_message);
# inject into the queue
CPAN::Queue->delete($self->id);
CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
# and run where we left off
my($method) = (caller(1))[3];
my $goto_do = CPAN->instance("CPAN::Distribution",$goto);
$goto_do->called_for($self->called_for) unless $goto_do->called_for;
$goto_do->{mandatory} ||= $self->{mandatory};
$goto_do->{reqtype} ||= $self->{reqtype};
$goto_do->{coming_from} = $self->pretty_id;
$goto_do->$method();
CPAN::Queue->delete_first($goto);
# XXX delete_first returns undef; is that what this should return
# up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
}
#-> sub CPAN::Distribution::shortcut_install ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_install {
my ($self) = @_;
$self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
if (exists $self->{install}) {
my $text = UNIVERSAL::can($self->{install},"text") ?
$self->{install}->text :
$self->{install};
if ($text =~ /^YES/) {
$CPAN::META->is_installed($self->{build_dir});
return $self->success("Already done");
} elsif ($text =~ /is only/) {
# e.g. 'is only build_requires': may be overruled later
return $self->goodbye($text);
} else {
# comment in Todo on 2006-02-11; maybe retry?
return $self->goodbye("Already tried without success");
}
}
for my $slot ( qw/later configure_requires_later/ ) {
return $self->success($self->{$slot})
if $self->{$slot};
}
return undef;
}
#-> sub CPAN::Distribution::is_being_sponsored ;
# returns true if we find a distro object in the queue that has
# sponsored this one
sub is_being_sponsored {
my($self) = @_;
my $iterator = CPAN::Queue->iterator;
QITEM: while (my $q = $iterator->()) {
my $s = $q->as_string;
my $obj = CPAN::Shell->expandany($s) or next QITEM;
my $type = ref $obj;
if ( $type eq 'CPAN::Distribution' ){
for my $module (sort keys %{$obj->{sponsored_mods} || {}}) {
return 1 if grep { $_ eq $module } $self->containsmods;
}
}
}
return 0;
}
#-> sub CPAN::Distribution::install ;
sub install {
my($self) = @_;
$self->pre_install();
if (exists $self->{cleanup_after_install_done}) {
return $self->test;
}
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$self->goto($goto);
$self->post_install();
return;
}
unless ($self->test) {
$self->post_install();
return;
}
if ( defined( my $sc = $self->shortcut_install ) ) {
$self->post_install();
return $sc;
}
if ($CPAN::Signal) {
delete $self->{force_update};
$self->post_install();
return;
}
my $builddir = $self->dir or
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
unless (chdir $builddir) {
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
$self->post_install();
return;
}
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
my $make = $self->{modulebuild} ? "Build" : "make";
$CPAN::Frontend->myprint(sprintf "Running %s install for %s\n", $make, $self->pretty_id);
if ($^O eq 'MacOS') {
Mac::BuildTools::make_install($self);
$self->post_install();
return;
}
my $system;
if (my $commandline = $self->prefs->{install}{commandline}) {
$system = $commandline;
$ENV{PERL} = CPAN::find_perl();
} elsif ($self->{modulebuild}) {
my($mbuild_install_build_command) =
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
$CPAN::Config->{mbuild_install_build_command} ?
$CPAN::Config->{mbuild_install_build_command} :
$self->_build_command();
my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
$system = sprintf("%s %s %s",
$mbuild_install_build_command,
$install_directive,
$CPAN::Config->{mbuild_install_arg},
);
} else {
my($make_install_make_command) = $self->_make_install_make_command();
$system = sprintf("%s install %s",
$make_install_make_command,
$CPAN::Config->{make_install_arg},
);
}
my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
my $brip = CPAN::HandleConfig->prefs_lookup($self,
q{build_requires_install_policy});
$brip ||="ask/yes";
my $id = $self->id;
my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
my $want_install = "yes";
if ($reqtype eq "b") {
if ($brip eq "no") {
$want_install = "no";
} elsif ($brip =~ m|^ask/(.+)|) {
my $default = $1;
$default = "yes" unless $default =~ /^(y|n)/i;
$want_install =
CPAN::Shell::colorable_makemaker_prompt
("$id is just needed temporarily during building or testing. ".
"Do you want to install it permanently?",
$default);
}
}
unless ($want_install =~ /^y/i) {
my $is_only = "is only 'build_requires'";
$self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
delete $self->{force_update};
$self->goodbye("Not installing because $is_only");
$self->post_install();
return;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
local $ENV{PERL_USE_UNSAFE_INC} =
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
$CPAN::META->set_perl5lib;
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
my $install_env;
if ($self->prefs->{install}) {
$install_env = $self->prefs->{install}{env};
}
local @ENV{keys %$install_env} = values %$install_env if $install_env;
if (! $run_allow_installing_within_test) {
my($allow_installing, $why) = $self->_allow_installing;
if (! $allow_installing) {
$CPAN::Frontend->mywarn("Installation stopped: $why\n");
$self->introduce_myself;
$self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
delete $self->{force_update};
$self->post_install();
return;
}
}
my($pipe) = FileHandle->new("$system $stderr |");
unless ($pipe) {
$CPAN::Frontend->mywarn("Can't execute $system: $!");
$self->introduce_myself;
$self->{install} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
delete $self->{force_update};
$self->post_install();
return;
}
my($makeout) = "";
while (<$pipe>) {
print $_; # intentionally NOT use Frontend->myprint because it
# looks irritating when we markup in color what we
# just pass through from an external program
$makeout .= $_;
}
$pipe->close;
my $close_ok = $? == 0;
$self->introduce_myself;
if ( $close_ok ) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_installed($self->{build_dir});
$self->{install} = CPAN::Distrostatus->new("YES");
if ($CPAN::Config->{'cleanup_after_install'}
&& ! $self->is_dot_dist
&& ! $self->is_being_sponsored) {
my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
File::Path::rmtree($self->{build_dir});
my $yml = "$self->{build_dir}.yml";
if (-e $yml) {
unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
}
$self->{cleanup_after_install_done}=1;
}
} else {
$self->{install} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
my $mimc =
CPAN::HandleConfig->prefs_lookup($self,
q{make_install_make_command});
if (
$makeout =~ /permission/s
&& $> > 0
&& (
! $mimc
|| $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
q{make}))
)
) {
$CPAN::Frontend->myprint(
qq{----\n}.
qq{ You may have to su }.
qq{to root to install the package\n}.
qq{ (Or you may want to run something like\n}.
qq{ o conf make_install_make_command 'sudo make'\n}.
qq{ to raise your permissions.}
);
}
}
delete $self->{force_update};
unless ($CPAN::Config->{'cleanup_after_install'}) {
$self->store_persistent_state;
}
$self->post_install();
return !! $close_ok;
}
sub blib_pm_walk {
my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch");
return sub {
LOOP: {
if (@queue) {
my $file = shift @queue;
if (-d $file) {
my $dh;
opendir $dh, $file or next;
my @newfiles = map {
my @ret;
my $maybedir = File::Spec->catdir($file, $_);
if (-d $maybedir) {
unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) {
# prune the blib/arch/auto directory, no pm files there
@ret = $maybedir;
}
} elsif (/\.pm$/) {
my $mustbefile = File::Spec->catfile($file, $_);
if (-f $mustbefile) {
@ret = $mustbefile;
}
}
@ret;
} grep {
$_ ne "."
&& $_ ne ".."
} readdir $dh;
push @queue, @newfiles;
redo LOOP;
} else {
return $file;
}
} else {
return;
}
}
};
}
sub _allow_installing {
my($self) = @_;
my $id = my $pretty_id = $self->pretty_id;
if ($self->{CALLED_FOR}) {
$id .= " (called for $self->{CALLED_FOR})";
}
my $allow_down = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades});
$allow_down ||= "ask/yes";
my $allow_outdd = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists});
$allow_outdd ||= "ask/yes";
return 1 if
$allow_down eq "yes"
&& $allow_outdd eq "yes";
if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) {
return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods;
if ($allow_outdd ne "yes") {
$CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as...
$allow_outdd = "yes";
}
}
return 1 if
$allow_down eq "yes"
&& $allow_outdd eq "yes";
my($dist_version, $dist_dist);
if ($allow_outdd ne "yes"){
my $dni = CPAN::DistnameInfo->new($pretty_id);
$dist_version = $dni->version;
$dist_dist = $dni->dist;
}
my $iterator = blib_pm_walk();
my(@down,@outdd);
while (my $file = $iterator->()) {
my $version = CPAN::Module->parse_version($file);
my($volume, $directories, $pmfile) = File::Spec->splitpath( $file );
my @dirs = File::Spec->splitdir( $directories );
my(@blib_plus1) = splice @dirs, 0, 2;
my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile);
unless ($allow_down eq "yes") {
if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) {
my $inst_version = CPAN::Module->parse_version($inst_file);
my $cmp = CPAN::Version->vcmp($version, $inst_version);
if ($cmp) {
if ($cmp < 0) {
push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version };
}
}
if (@down) {
my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')";
if (my($default) = $allow_down =~ m|^ask/(.+)|) {
$default = "yes" unless $default =~ /^(y|n)/i;
my $answer = CPAN::Shell::colorable_makemaker_prompt
("$why. Do you want to allow installing it?",
$default, "colorize_warn");
$allow_down = $answer =~ /^\s*y/i ? "yes" : "no";
}
if ($allow_down eq "no") {
return (0, $why);
}
}
}
}
unless ($allow_outdd eq "yes") {
my @pmpath = (@dirs, $pmfile);
$pmpath[-1] =~ s/\.pm$//;
my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath);
if ($mo) {
my $cpan_version = $mo->cpan_version;
my $is_lower = CPAN::Version->vlt($version, $cpan_version);
my $other_dist;
lib/CPAN/Distribution.pm view on Meta::CPAN
if ($@) {
$CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
return;
} else {
my($var);
$Ua->proxy('http', $var)
if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
$Ua->no_proxy($var)
if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
}
my $req = HTTP::Request->new(GET => $url);
$req->header('Accept' => 'text/html');
my $res = $Ua->request($req);
if ($res->is_success) {
$CPAN::Frontend->myprint(" + request successful.\n")
if $CPAN::DEBUG;
print $fh $res->content;
close $fh;
$CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
if $CPAN::DEBUG;
return $tmpin;
} else {
$CPAN::Frontend->myprint(sprintf(
"LWP failed with code[%s], message[%s]\n",
$res->code,
$res->message,
));
return;
}
} else {
$CPAN::Frontend->mywarn(" LWP not available\n");
return;
}
}
#-> sub CPAN::Distribution::_build_command
sub _build_command {
my($self) = @_;
if ($^O eq "MSWin32") { # special code needed at least up to
# Module::Build 0.2611 and 0.2706; a fix
# in M:B has been promised 2006-01-30
my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
return "$perl ./Build";
}
elsif ($^O eq 'VMS') {
return "$^X Build.com";
}
return "./Build";
}
#-> sub CPAN::Distribution::_should_report
sub _should_report {
my($self, $phase) = @_;
die "_should_report() requires a 'phase' argument"
if ! defined $phase;
return unless $CPAN::META->has_usable("CPAN::Reporter");
# configured
my $test_report = CPAN::HandleConfig->prefs_lookup($self,
q{test_report});
return unless $test_report;
# don't repeat if we cached a result
return $self->{should_report}
if exists $self->{should_report};
# don't report if we generated a Makefile.PL
if ( $self->{had_no_makefile_pl} ) {
$CPAN::Frontend->mywarn(
"Will not send CPAN Testers report with generated Makefile.PL.\n"
);
return $self->{should_report} = 0;
}
# available
if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
$CPAN::Frontend->mywarnonce(
"CPAN::Reporter not installed. No reports will be sent.\n"
);
return $self->{should_report} = 0;
}
# capable
my $crv = CPAN::Reporter->VERSION;
if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
# don't cache $self->{should_report} -- need to check each phase
if ( $phase eq 'test' ) {
return 1;
}
else {
$CPAN::Frontend->mywarn(
"Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
"you only have version $crv\. Only 'test' phase reports will be sent.\n"
);
return;
}
}
# appropriate
if ($self->is_dot_dist) {
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
"for local directories\n");
return $self->{should_report} = 0;
}
if ($self->prefs->{patches}
&&
@{$self->prefs->{patches}}
&&
$self->{patched}
) {
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
"when the source has been patched\n");
return $self->{should_report} = 0;
}
# proceed and cache success
return $self->{should_report} = 1;
}
#-> sub CPAN::Distribution::reports
sub reports {
my($self) = @_;
my $pathname = $self->id;
$CPAN::Frontend->myprint("Distribution: $pathname\n");
unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
$CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
}
unless ($CPAN::META->has_usable("LWP")) {
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
}
unless ($CPAN::META->has_usable("File::Temp")) {
$CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
}
my $format;
if ($CPAN::META->has_inst("YAML::XS") || $CPAN::META->has_inst("YAML::Syck")){
$format = 'yaml';
}
elsif (!$format && $CPAN::META->has_inst("JSON::PP") ) {
$format = 'json';
}
else {
$CPAN::Frontend->mydie("JSON::PP not installed, cannot continue");
}
my $d = CPAN::DistnameInfo->new($pathname);
my $dist = $d->dist; # "CPAN-DistnameInfo"
my $version = $d->version; # "0.02"
my $maturity = $d->maturity; # "released"
my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
my $cpanid = $d->cpanid; # "GBARR"
my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
my $url = sprintf "http://www.cpantesters.org/show/%s.%s", $dist, $format;
CPAN::LWP::UserAgent->config;
my $Ua;
eval { $Ua = CPAN::LWP::UserAgent->new; };
if ($@) {
$CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
}
$CPAN::Frontend->myprint("Fetching '$url'...");
my $resp = $Ua->get($url);
unless ($resp->is_success) {
$CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
( run in 1.085 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )