# -*- 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 ();
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
$VERSION = "1.9602_01";
# 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 ".";
}
# add the A/AN/ stuff
#-> CPAN::Distribution::normalize
sub normalize {
my($self,$s) = @_;
$s = $self->id unless defined $s;
if (substr($s,-1,1) eq ".") {
# using a global because we are sometimes called as static method
if (!$CPAN::META->{LOCK}
&& !$CPAN::Have_warned->{"$s is unlocked"}++
) {
$CPAN::Frontend->mywarn("You are visiting the local directory
'$s'
without lock, take care that concurrent processes do not do likewise.\n");
$CPAN::Frontend->mysleep(1);
}
if ($s eq ".") {
$s = "$CPAN::iCwd/.";
} elsif (File::Spec->file_name_is_absolute($s)) {
} elsif (File::Spec->can("rel2abs")) {
$s = File::Spec->rel2abs($s);
} else {
$CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
}
CPAN->debug("s[$s]") if $CPAN::DEBUG;
unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
for ($CPAN::META->instance("CPAN::Distribution", $s)) {
$_->{build_dir} = $s;
$_->{archived} = "local_directory";
$_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
}
}
} elsif (
$s =~ tr|/|| == 1
or
$s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
) {
return $s if $s =~ m:^N/A|^Contact Author: ;
$s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
CPAN->debug("s[$s]") if $CPAN::DEBUG;
}
$s;
}
#-> sub CPAN::Distribution::author ;
sub author {
my($self) = @_;
my($authorid);
if (substr($self->id,-1,1) eq ".") {
$authorid = "LOCAL";
} else {
($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
}
CPAN::Shell->expand("Author",$authorid);
}
# tries to get the yaml from CPAN instead of the distro itself:
# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
sub fast_yaml {
my($self) = @_;
my $meta = $self->pretty_id;
$meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
my(@ls) = CPAN::Shell->globls($meta);
my $norm = $self->normalize($meta);
my($local_file);
my($local_wanted) =
File::Spec->catfile(
$CPAN::Config->{keep_source_where},
"authors",
"id",
split(/\//,$norm)
);
$self->debug("Doing localize") if $CPAN::DEBUG;
unless ($local_file =
CPAN::FTP->localize("authors/id/$norm",
$local_wanted)) {
$CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
}
my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
}
#-> sub CPAN::Distribution::cpan_userid
sub cpan_userid {
my $self = shift;
if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
return $1;
}
return $self->SUPER::cpan_userid;
}
#-> sub CPAN::Distribution::pretty_id
sub pretty_id {
my $self = shift;
my $id = $self->id;
return $id unless $id =~ m|^./../|;
substr($id,5);
}
#-> sub CPAN::Distribution::base_id
sub base_id {
my $self = shift;
my $id = $self->pretty_id();
my $base_id = File::Basename::basename($id);
$base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
return $base_id;
}
#-> sub CPAN::Distribution::tested_ok_but_not_installed
sub tested_ok_but_not_installed {
my $self = shift;
return (
$self->{make_test}
&& $self->{build_dir}
&& (UNIVERSAL::can($self->{make_test},"failed") ?
! $self->{make_test}->failed :
$self->{make_test} =~ /^YES/
)
&& (
!$self->{install}
||
$self->{install}->failed
)
);
}
# mark as dirty/clean for the sake of recursion detection. $color=1
# means "in use", $color=0 means "not in use anymore". $color=2 means
# we have determined prereqs now and thus insist on passing this
# through (at least) once again.
#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
my($self) = shift;
my($depth) = shift || 0;
my($color) = shift || 0;
my($ancestors) = shift || [];
# a distribution needs to recurse into its prereq_pms
$self->debug("color_cmd_tmps[$depth,$color,@$ancestors]") if $CPAN::DEBUG;
return if exists $self->{incommandcolor}
&& $color==1
&& $self->{incommandcolor}==$color;
if ($depth>=$CPAN::MAX_RECURSION) {
die(CPAN::Exception::RecursiveDependency->new($ancestors));
}
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
my $prereq_pm = $self->prereq_pm;
if (defined $prereq_pm) {
PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
keys %{$prereq_pm->{build_requires}||{}}) {
next PREREQ if $pre eq "perl";
my $premo;
unless ($premo = CPAN::Shell->expand("Module",$pre)) {
$CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
$CPAN::Frontend->mysleep(0.2);
next PREREQ;
}
$premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
}
}
if ($color==0) {
delete $self->{sponsored_mods};
# as we are at the end of a command, we'll give up this
# reminder of a broken test. Other commands may test this guy
# again. Maybe 'badtestcnt' should be renamed to
# 'make_test_failed_within_command'?
delete $self->{badtestcnt};
}
$self->{incommandcolor} = $color;
}
#-> sub CPAN::Distribution::as_string ;
sub as_string {
my $self = shift;
$self->containsmods;
$self->upload_date;
$self->SUPER::as_string(@_);
}
#-> sub CPAN::Distribution::containsmods ;
sub containsmods {
my $self = shift;
return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
my $dist_id = $self->{ID};
for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
my $mod_file = $mod->cpan_file or next;
my $mod_id = $mod->{ID} or next;
# warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
# sleep 1;
if ($CPAN::Signal) {
delete $self->{CONTAINSMODS};
return;
}
$self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
}
keys %{$self->{CONTAINSMODS}||={}};
}
#-> sub CPAN::Distribution::upload_date ;
sub upload_date {
my $self = shift;
return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
my(@local_wanted) = split(/\//,$self->id);
my $filename = pop @local_wanted;
push @local_wanted, "CHECKSUMS";
my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
return unless $author;
my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
return unless @dl;
my($dirent) = grep { $_->[2] eq $filename } @dl;
# warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
return unless $dirent->[1];
return $self->{UPLOAD_DATE} = $dirent->[1];
}
#-> sub CPAN::Distribution::uptodate ;
sub uptodate {
my($self) = @_;
my $c;
foreach $c ($self->containsmods) {
my $obj = CPAN::Shell->expandany($c);
unless ($obj->uptodate) {
my $id = $self->pretty_id;
$self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
return 0;
}
}
return 1;
}
#-> sub CPAN::Distribution::called_for ;
sub called_for {
my($self,$id) = @_;
$self->{CALLED_FOR} = $id if defined $id;
return $self->{CALLED_FOR};
}
#-> sub CPAN::Distribution::get ;
sub get {
my($self) = @_;
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
if (my $goto = $self->prefs->{goto}) {
$CPAN::Frontend->mywarn
(sprintf(
"delegating to '%s' as specified in prefs file '%s' doc %d\n",
$goto,
$self->{prefs_file},
$self->{prefs_file_doc},
));
return $self->goto($goto);
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
EXCUSE: {
my @e;
my $goodbye_message;
$self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
if ($self->prefs->{disabled} && ! $self->{force_update}) {
my $why = sprintf(
"Disabled via prefs file '%s' doc %d",
$self->{prefs_file},
$self->{prefs_file_doc},
);
push @e, $why;
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
$goodbye_message = "[disabled] -- NA $why";
# note: not intended to be persistent but at least visible
# during this session
} else {
if (exists $self->{build_dir} && -d $self->{build_dir}
&& ($self->{modulebuild}||$self->{writemakefile})
) {
# this deserves print, not warn:
$CPAN::Frontend->myprint(" Has already been unwrapped into directory ".
"$self->{build_dir}\n"
);
return 1;
}
# although we talk about 'force' we shall not test on
# force directly. New model of force tries to refrain from
# direct checking of force.
exists $self->{unwrapped} and (
UNIVERSAL::can($self->{unwrapped},"failed") ?
$self->{unwrapped}->failed :
$self->{unwrapped} =~ /^NO/
)
and push @e, "Unwrapping had some problem, won't try again without force";
}
if (@e) {
$CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
if ($goodbye_message) {
$self->goodbye($goodbye_message);
}
return;
}
}
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
my($local_file);
unless ($self->{build_dir} && -d $self->{build_dir}) {
$self->get_file_onto_local_disk;
return if $CPAN::Signal;
$self->check_integrity;
return if $CPAN::Signal;
(my $packagedir,$local_file) = $self->run_preps_on_packagedir;
if (exists $self->{writemakefile} && ref $self->{writemakefile}
&& $self->{writemakefile}->can("failed") &&
$self->{writemakefile}->failed) {
return;
}
$packagedir ||= $self->{build_dir};
$self->{build_dir} = $packagedir;
}
if ($CPAN::Signal) {
$self->safe_chdir($sub_wd);
return;
}
return $self->choose_MM_or_MB($local_file);
}
#-> CPAN::Distribution::get_file_onto_local_disk
sub get_file_onto_local_disk {
my($self) = @_;
return if $self->is_dot_dist;
my($local_file);
my($local_wanted) =
File::Spec->catfile(
$CPAN::Config->{keep_source_where},
"authors",
"id",
split(/\//,$self->id)
);
$self->debug("Doing localize") if $CPAN::DEBUG;
unless ($local_file =
CPAN::FTP->localize("authors/id/$self->{ID}",
$local_wanted)) {
my $note = "";
if ($CPAN::Index::DATE_OF_02) {
$note = "Note: Current database in memory was generated ".
"on $CPAN::Index::DATE_OF_02\n";
}
$CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
}
$self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
$self->{localfile} = $local_file;
}
#-> CPAN::Distribution::check_integrity
sub check_integrity {
my($self) = @_;
return if $self->is_dot_dist;
if ($CPAN::META->has_inst("Digest::SHA")) {
$self->debug("Digest::SHA is installed, verifying");
$self->verifyCHECKSUM;
} else {
$self->debug("Digest::SHA is NOT installed");
}
}
#-> CPAN::Distribution::run_preps_on_packagedir
sub run_preps_on_packagedir {
my($self) = @_;
return if $self->is_dot_dist;
$CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
$self->safe_chdir($builddir);
$self->debug("Removing tmp-$$") if $CPAN::DEBUG;
File::Path::rmtree("tmp-$$");
unless (mkdir "tmp-$$", 0755) {
$CPAN::Frontend->unrecoverable_error(<<EOF);
Couldn't mkdir '$builddir/tmp-$$': $!
Cannot continue: Please find the reason why I cannot make the
directory
$builddir/tmp-$$
and fix the problem, then retry.
EOF
}
if ($CPAN::Signal) {
return;
}
$self->safe_chdir("tmp-$$");
#
# Unpack the goods
#
my $local_file = $self->{localfile};
my $ct = eval{CPAN::Tarzip->new($local_file)};
unless ($ct) {
$self->{unwrapped} = CPAN::Distrostatus->new("NO");
delete $self->{build_dir};
return;
}
if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
$self->{was_uncompressed}++ unless eval{$ct->gtest()};
$self->untar_me($ct);
} elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
$self->unzip_me($ct);
} else {
$self->{was_uncompressed}++ unless $ct->gtest();
$local_file = $self->handle_singlefile($local_file);
}
# we are still in the tmp directory!
# Let's check if the package has its own directory.
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir .: $!");
my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
if (grep { $_ eq "pax_global_header" } @readdir) {
$CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
from the tarball '$local_file'.
This is almost certainly an error. Please upgrade your tar.
I'll ignore this file for now.
See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
$CPAN::Frontend->mysleep(5);
@readdir = grep { $_ ne "pax_global_header" } @readdir;
}
$dh->close;
my ($packagedir);
# XXX here we want in each branch File::Temp to protect all build_dir directories
if (CPAN->has_usable("File::Temp")) {
my $tdir_base;
my $from_dir;
my @dirents;
if (@readdir == 1 && -d $readdir[0]) {
$tdir_base = $readdir[0];
$from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
my $dh2;
unless ($dh2 = DirHandle->new($from_dir)) {
my($mode) = (stat $from_dir)[2];
my $why = sprintf
(
"Couldn't opendir '%s', mode '%o': %s",
$from_dir,
$mode,
$!,
);
$CPAN::Frontend->mywarn("$why\n");
$self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
return;
}
@dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
} else {
my $userid = $self->cpan_userid;
CPAN->debug("userid[$userid]");
if (!$userid or $userid eq "N/A") {
$userid = "anon";
}
$tdir_base = $userid;
$from_dir = File::Spec->curdir;
@dirents = @readdir;
}
eval { File::Path::mkpath $builddir; };
if ($@) {
$CPAN::Frontend->mydie("Cannot create directory $builddir: $@");
}
$packagedir = File::Temp::tempdir(
"$tdir_base-XXXXXX",
DIR => $builddir,
CLEANUP => 0,
);
chmod 0777 &~ umask, $packagedir; # may fail
my $f;
for $f (@dirents) { # is already without "." and ".."
my $from = File::Spec->catdir($from_dir,$f);
my $to = File::Spec->catdir($packagedir,$f);
unless (File::Copy::move($from,$to)) {
my $err = $!;
$from = File::Spec->rel2abs($from);
Carp::confess("Couldn't move $from to $to: $err");
}
}
} else { # older code below, still better than nothing when there is no File::Temp
my($distdir);
if (@readdir == 1 && -d $readdir[0]) {
$distdir = $readdir[0];
$packagedir = File::Spec->catdir($builddir,$distdir);
$self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
if $CPAN::DEBUG;
-d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
"$packagedir\n");
File::Path::rmtree($packagedir);
unless (File::Copy::move($distdir,$packagedir)) {
$CPAN::Frontend->unrecoverable_error(<<EOF);
Couldn't move '$distdir' to '$packagedir': $!
Cannot continue: Please find the reason why I cannot move
$builddir/tmp-$$/$distdir
to
$packagedir
and fix the problem, then retry
EOF
}
$self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
$distdir,
$packagedir,
-e $packagedir,
-d $packagedir,
)) if $CPAN::DEBUG;
} else {
my $userid = $self->cpan_userid;
CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
if (!$userid or $userid eq "N/A") {
$userid = "anon";
}
my $pragmatic_dir = $userid . '000';
$pragmatic_dir =~ s/\W_//g;
$pragmatic_dir++ while -d "../$pragmatic_dir";
$packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
$self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
File::Path::mkpath($packagedir);
my($f);
for $f (@readdir) { # is already without "." and ".."
my $to = File::Spec->catdir($packagedir,$f);
File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
}
}
}
$self->{build_dir} = $packagedir;
$self->safe_chdir($builddir);
File::Path::rmtree("tmp-$$");
$self->safe_chdir($packagedir);
$self->_signature_business();
$self->safe_chdir($builddir);
return($packagedir,$local_file);
}
#-> sub CPAN::Distribution::pick_meta_file ;
sub pick_meta_file {
my($self, $filter) = @_;
$filter = '.' unless defined $filter;
my $build_dir;
unless ($build_dir = $self->{build_dir}) {
# maybe permission on build_dir was missing
$CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
return;
}
my $has_cm = $CPAN::META->has_usable("CPAN::Meta");
my $has_pcm = $CPAN::META->has_usable("Parse::CPAN::Meta");
my @choices;
push @choices, 'MYMETA.json' if $has_cm;
push @choices, 'MYMETA.yml' if $has_cm || $has_pcm;
push @choices, 'META.json' if $has_cm;
push @choices, 'META.yml' if $has_cm || $has_pcm;
for my $file ( grep { /$filter/ } @choices ) {
my $path = File::Spec->catdir( $build_dir, $file );
return $path if -f $path
}
return;
}
#-> sub CPAN::Distribution::parse_meta_yml ;
sub parse_meta_yml {
my($self, $yaml) = @_;
$self->debug(sprintf("parse_meta_yml[%s]",$yaml||'undef')) if $CPAN::DEBUG;
my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
$yaml ||= File::Spec->catfile($build_dir,"META.yml");
$self->debug("meta[$yaml]") if $CPAN::DEBUG;
return unless -f $yaml;
my $early_yaml;
eval {
$CPAN::META->has_inst("Parse::CPAN::Meta") or die;
die "Parse::CPAN::Meta yaml too old" unless $Parse::CPAN::Meta::VERSION >= "1.40";
# P::C::M returns last document in scalar context
$early_yaml = Parse::CPAN::Meta::LoadFile($yaml);
};
unless ($early_yaml) {
eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
}
$self->debug(sprintf("yaml[%s]", $early_yaml || 'UNDEF')) if $CPAN::DEBUG;
$self->debug($early_yaml) if $CPAN::DEBUG && $early_yaml;
return $early_yaml || undef;
}
#-> sub CPAN::Distribution::satisfy_requires ;
sub satisfy_requires {
my ($self) = @_;
$self->debug("Entering satisfy_requires") if $CPAN::DEBUG;
if (my @prereq = $self->unsat_prereq("later")) {
$self->debug("unsatisfied[@prereq]") if $CPAN::DEBUG;
$self->debug(@prereq) if $CPAN::DEBUG && @prereq;
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;
die "[prereq] -- NOT OK\n";
} else {
my $follow = eval { $self->follow_prereqs("later",@prereq); };
if (0) {
} elsif ($follow) {
# signal success to the queuerunner
return 1;
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
$CPAN::Frontend->mywarn($@);
die "[depend] -- NOT OK\n";
}
}
}
return;
}
#-> sub CPAN::Distribution::satisfy_configure_requires ;
sub satisfy_configure_requires {
my($self) = @_;
$self->debug("Entering satisfy_configure_requires") if $CPAN::DEBUG;
my $enable_configure_requires = 1;
if (!$enable_configure_requires) {
return 1;
# if we return 1 here, everything is as before we introduced
# configure_requires that means, things with
# configure_requires simply fail, all others succeed
}
my @prereq = $self->unsat_prereq("configure_requires_later");
$self->debug(sprintf "configure_requires[%s]", join(",",map {join "/",@$_} @prereq)) if $CPAN::DEBUG;
return 1 unless @prereq;
$self->debug(\@prereq) if $CPAN::DEBUG;
if ($self->{configure_requires_later}) {
for my $k (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;
} 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,$local_file) = @_;
$self->satisfy_configure_requires() or return;
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";
}
}
return unless $self->patch;
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;
}
#-> CPAN::Distribution::store_persistent_state
sub store_persistent_state {
my($self) = @_;
my $dir = $self->{build_dir};
unless (File::Spec->canonpath(File::Basename::dirname($dir))
eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
$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("Going to apply $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);
if ($ppp eq "applypatch") {
$pcommand = "$CPAN::Config->{applypatch} -verbose";
} else {
my $thispatchargs = join " ", $stdpatchargs, $ppp;
$pcommand = "$patchbin $thispatchargs";
require Config; # usually loaded from CPAN.pm
if ($Config::Config{osname} eq "solaris") {
# native solaris patch cannot patch readonly files
for my $file (@{$pfiles||[]}) {
my @stat = stat $file or next;
chmod $stat[2] | 0600, $file; # may fail
}
}
}
$readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
my $writefh = FileHandle->new;
$CPAN::Frontend->myprint(" $pcommand\n");
unless (open $writefh, "|$pcommand") {
my $fail = "Could not fork '$pcommand'";
$CPAN::Frontend->mywarn("$fail; cannot continue\n");
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
delete $self->{build_dir};
return;
}
binmode($writefh);
while (my $x = $readfh->READLINE) {
print $writefh $x;
}
unless (close $writefh) {
my $fail = "Could not apply patch '$patch'";
$CPAN::Frontend->mywarn("$fail; cannot continue\n");
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
delete $self->{build_dir};
return;
}
}
$self->{patched}++;
}
return 1;
}
}
# may return
# - "applypatch"
# - ("-p0"|"-p1", $files)
sub _patch_p_parameter {
my($self,$fh) = @_;
my $cnt_files = 0;
my $cnt_p0files = 0;
my @files;
local($_);
while ($_ = $fh->READLINE) {
if (
$CPAN::Config->{applypatch}
&&
/\#\#\#\# ApplyPatch data follows \#\#\#\#/
) {
return "applypatch"
}
next unless /^[\*\+]{3}\s(\S+)/;
my $file = $1;
push @files, $file;
$cnt_files++;
$cnt_p0files++ if -f $file;
CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
if $CPAN::DEBUG;
}
return "-p1" unless $cnt_files;
my $opt_p = $cnt_files==$cnt_p0files ? "-p0" : "-p1";
return ($opt_p, \@files);
}
#-> sub CPAN::Distribution::_edge_cases
# with "configure" or "Makefile" or single file scripts
sub _edge_cases {
my($self,$mpl,$local_file) = @_;
$self->debug(sprintf("makefilepl[%s]anycwd[%s]",
$mpl,
CPAN::anycwd(),
)) if $CPAN::DEBUG;
my $build_dir = $self->{build_dir};
my($configure) = File::Spec->catfile($build_dir,"Configure");
if (-f $configure) {
# do we have anything to do?
$self->{configure} = $configure;
} elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
$CPAN::Frontend->mywarn(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
$CPAN::Frontend->mysleep(2);
} else {
my $cf = $self->called_for || "unknown";
if ($cf =~ m|/|) {
$cf =~ s|.*/||;
$cf =~ s|\W.*||;
}
$cf =~ s|[/\\:]||g; # risk of filesystem damage
$cf = "unknown" unless length($cf);
if (my $crud = $self->_contains_crud($build_dir)) {
my $why = qq{Package contains $crud; not recognized as a perl package, giving up};
$CPAN::Frontend->mywarn("$why\n");
$self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
return;
}
$CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
(The test -f "$mpl" returned false.)
Writing one on our own (setting NAME to $cf)\a\n});
$self->{had_no_makefile_pl}++;
$CPAN::Frontend->mysleep(3);
# Writing our own Makefile.PL
my $exefile_stanza = "";
if ($self->{archived} eq "maybe_pl") {
$exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
}
my $fh = FileHandle->new;
$fh->open(">$mpl")
or Carp::croak("Could not open >$mpl: $!");
$fh->print(
qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
# because there was no Makefile.PL supplied.
# Autogenerated on: }.scalar localtime().qq{
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => q[$cf],$exefile_stanza
);
});
$fh->close;
}
}
#-> CPAN;:Distribution::_contains_crud
sub _contains_crud {
my($self,$dir) = @_;
my(@dirs, $dh, @files);
opendir $dh, $dir or return;
my $dirent;
for $dirent (readdir $dh) {
next if $dirent =~ /^\.\.?$/;
my $path = File::Spec->catdir($dir,$dirent);
if (-d $path) {
push @dirs, $dirent;
} elsif (-f $path) {
push @files, $dirent;
}
}
if (@dirs && @files) {
return "both files[@files] and directories[@dirs]";
} elsif (@files > 2) {
return "several files[@files] but no Makefile.PL or Build.PL";
}
return;
}
#-> CPAN;:Distribution::_exefile_stanza
sub _exefile_stanza {
my($self,$build_dir,$local_file) = @_;
my $fh = FileHandle->new;
my $script_file = File::Spec->catfile($build_dir,$local_file);
$fh->open($script_file)
or Carp::croak("Could not open script '$script_file': $!");
local $/ = "\n";
# name parsen und prereq
my($state) = "poddir";
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 {
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
}
}
# CPAN::Distribution::unzip_me ;
sub unzip_me {
my($self,$ct) = @_;
$self->{archived} = "zip";
if ($ct->unzip()) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
}
return;
}
sub handle_singlefile {
my($self,$local_file) = @_;
if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
$self->{archived} = "pm";
} elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
$self->{archived} = "patch";
} else {
$self->{archived} = "maybe_pl";
}
my $to = File::Basename::basename($local_file);
if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
}
} else {
if (File::Copy::cp($local_file,".")) {
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
} else {
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
}
}
return $to;
}
#-> sub CPAN::Distribution::new ;
sub new {
my($class,%att) = @_;
# $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
my $this = { %att };
return bless $this, $class;
}
#-> sub CPAN::Distribution::look ;
sub look {
my($self) = @_;
if ($^O eq 'MacOS') {
$self->Mac::BuildTools::look;
return;
}
if ( $CPAN::Config->{'shell'} ) {
$CPAN::Frontend->myprint(qq{
Trying to open a subshell in the build directory...
});
} else {
$CPAN::Frontend->myprint(qq{
Your configuration does not define a value for subshells.
Please define it with "o conf shell <your shell>"
});
return;
}
my $dist = $self->id;
my $dir;
unless ($dir = $self->dir) {
$self->get;
}
unless ($dir ||= $self->dir) {
$CPAN::Frontend->mywarn(qq{
Could not determine which directory to use for looking at $dist.
});
return;
}
my $pwd = CPAN::anycwd();
$self->safe_chdir($dir);
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
{
local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
$ENV{CPAN_SHELL_LEVEL} += 1;
my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
unless (system($shell) == 0) {
my $code = $? >> 8;
$CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
}
}
$self->safe_chdir($pwd);
}
# CPAN::Distribution::cvs_import ;
sub cvs_import {
my($self) = @_;
$self->get;
my $dir = $self->dir;
my $package = $self->called_for;
my $module = $CPAN::META->instance('CPAN::Module', $package);
my $version = $module->cpan_version;
my $userid = $self->cpan_userid;
my $cvs_dir = (split /\//, $dir)[-1];
$cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
my $cvs_site_perl =
$CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
if ($cvs_site_perl) {
$cvs_dir = "$cvs_site_perl/$cvs_dir";
}
my $cvs_log = qq{"imported $package $version sources"};
$version =~ s/\./_/g;
# XXX cvs: undocumented and unclear how it was meant to work
my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
"$cvs_dir", $userid, "v$version");
my $pwd = CPAN::anycwd();
chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
$CPAN::Frontend->myprint(qq{@cmd\n});
system(@cmd) == 0 or
# XXX cvs
$CPAN::Frontend->mydie("cvs import failed");
chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}
#-> sub CPAN::Distribution::readme ;
sub readme {
my($self) = @_;
my($dist) = $self->id;
my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
$self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
my($local_file);
my($local_wanted) =
File::Spec->catfile(
$CPAN::Config->{keep_source_where},
"authors",
"id",
split(/\//,"$sans.readme"),
);
my $readme = "authors/id/$sans.readme";
$self->debug("Doing localize for '$readme'") if $CPAN::DEBUG;
$local_file = CPAN::FTP->localize($readme,
$local_wanted)
or $CPAN::Frontend->mydie(qq{No $sans.readme found});
if ($^O eq 'MacOS') {
Mac::BuildTools::launch_file($local_file);
return;
}
my $fh_pager = FileHandle->new;
local($SIG{PIPE}) = "IGNORE";
my $pager = $CPAN::Config->{'pager'} || "cat";
$fh_pager->open("|$pager")
or die "Could not open pager $pager\: $!";
my $fh_readme = FileHandle->new;
$fh_readme->open($local_file)
or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
$CPAN::Frontend->myprint(qq{
Displaying file
$local_file
with pager "$pager"
});
$fh_pager->print(<$fh_readme>);
$fh_pager->close;
}
#-> sub CPAN::Distribution::verifyCHECKSUM ;
sub verifyCHECKSUM {
my($self) = @_;
EXCUSE: {
my @e;
$self->{CHECKSUM_STATUS} ||= "";
$self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
my($lc_want,$lc_file,@local,$basename);
@local = split(/\//,$self->id);
pop @local;
push @local, "CHECKSUMS";
$lc_want =
File::Spec->catfile($CPAN::Config->{keep_source_where},
"authors", "id", @local);
local($") = "/";
if (my $size = -s $lc_want) {
$self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
if ($self->CHECKSUM_check_file($lc_want,1)) {
return $self->{CHECKSUM_STATUS} = "OK";
}
}
$lc_file = CPAN::FTP->localize("authors/id/@local",
$lc_want,1);
unless ($lc_file) {
$CPAN::Frontend->myprint("Trying $lc_want.gz\n");
$local[-1] .= ".gz";
$lc_file = CPAN::FTP->localize("authors/id/@local",
"$lc_want.gz",1);
if ($lc_file) {
$lc_file =~ s/\.gz(?!\n)\Z//;
eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
} else {
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 == Module::Signature::SIGNATURE_OK()) {
$CPAN::Frontend->myprint("Signature for $chk_file ok\n");
return $self->{SIG_STATUS} = "OK";
} else {
$CPAN::Frontend->myprint(qq{\nSignature invalid for }.
qq{distribution file. }.
qq{Please investigate.\n\n}.
$self->as_string,
$CPAN::META->instance(
'CPAN::Author',
$self->cpan_userid
)->as_string);
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 $fh = FileHandle->new;
if (open $fh, $chk_file) {
local($/);
my $eval = <$fh>;
$eval =~ s/\015?\012/\n/g;
close $fh;
my($compmt) = Safe->new();
$cksum = $compmt->reval($eval);
if ($@) {
rename $chk_file, "$chk_file.bad";
Carp::confess($@) if $@;
}
} else {
Carp::carp "Could not open $chk_file for reading";
}
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");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
$self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
return;
} elsif (exists $cksum->{$basename}{sha256}) {
$self->debug("Found checksum for $basename:" .
"$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
open($fh, $file);
binmode $fh;
my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
$fh->close;
$fh = CPAN::Tarzip->TIEHANDLE($file);
unless ($eq) {
my $dg = Digest::SHA->new(256);
my($data,$ref);
$ref = \$data;
while ($fh->READ($ref, 4096) > 0) {
$dg->add($data);
}
my $hexdigest = $dg->hexdigest;
$eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
}
if ($eq) {
$CPAN::Frontend->myprint("Checksum for $file ok\n");
return $self->{CHECKSUM_STATUS} = "OK";
} else {
$CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
qq{distribution file. }.
qq{Please investigate.\n\n}.
$self->as_string,
$CPAN::META->instance(
'CPAN::Author',
$self->cpan_userid
)->as_string);
my $wrap = qq{I\'d recommend removing $file. Its
checksum is incorrect. 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));
# former versions just returned here but this seems a
# serious threat that deserves a die
# $CPAN::Frontend->myprint("\n\n");
# sleep 3;
# return;
}
# close $fh if fileno($fh);
} else {
return if $sloppy;
unless ($self->{CHECKSUM_STATUS}) {
$CPAN::Frontend->mywarn(qq{
Warning: No checksum for $basename in $chk_file.
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",
],
make => [
"writemakefile",
"make",
"modulebuild",
"prereq_pm",
],
test => [
"badtestcnt",
"make_test",
],
install => [
"install",
],
unknown => [
"reqtype",
"yaml_content",
],
);
my $methodmatch = 0;
my $ldebug = 0;
PHASE: for my $phase (qw(unknown get make test install)) { # order matters
$methodmatch = 1 if $fforce || $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/) {
$self->{force_update} = 1; # name should probably have been force_install
}
}
#-> sub CPAN::Distribution::notest ;
sub notest {
my($self, $method) = @_;
# $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
$self->{"notest"}++; # name should probably have been force_install
}
#-> sub CPAN::Distribution::unnotest ;
sub unnotest {
my($self) = @_;
# warn "XDEBUG: deleting notest";
delete $self->{notest};
}
#-> sub CPAN::Distribution::unforce ;
sub unforce {
my($self) = @_;
delete $self->{force_update};
}
#-> sub CPAN::Distribution::isa_perl ;
sub isa_perl {
my($self) = @_;
my $file = File::Basename::basename($self->id);
if ($file =~ m{ ^ perl
-?
(5)
([._-])
(
\d{3}(_[0-4][0-9])?
|
\d+\.\d+
)
\.tar[._-](?:gz|bz2)
(?!\n)\Z
}xs) {
return "$1.$3";
} elsif ($self->cpan_comment
&&
$self->cpan_comment =~ /isa_perl\(.+?\)/) {
return $1;
}
}
#-> sub CPAN::Distribution::perl ;
sub perl {
my ($self) = @_;
if (! $self) {
use Carp qw(carp);
carp __PACKAGE__ . "::perl was called without parameters.";
}
return CPAN::HandleConfig->safe_quote($CPAN::Perl);
}
#-> sub CPAN::Distribution::make ;
sub make {
my($self) = @_;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
my $make = $self->{modulebuild} ? "Build" : "make";
# Emergency brake if they said install Pippi and get newest perl
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->id,
));
$self->{make} = CPAN::Distrostatus->new("NO isa perl");
$CPAN::Frontend->mysleep(1);
return;
}
}
$CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
$self->get;
return if $self->prefs->{disabled} && ! $self->{force_update};
if ($self->{configure_requires_later}) {
return;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $builddir;
EXCUSE: {
my @e;
if (!$self->{archived} || $self->{archived} eq "NO") {
push @e, "Is neither a tar nor a zip archive.";
}
if (!$self->{unwrapped}
|| (
UNIVERSAL::can($self->{unwrapped},"failed") ?
$self->{unwrapped}->failed :
$self->{unwrapped} =~ /^NO/
)) {
push @e, "Had problems unarchiving. Please build manually";
}
unless ($self->{force_update}) {
exists $self->{signature_verify} and
(
UNIVERSAL::can($self->{signature_verify},"failed") ?
$self->{signature_verify}->failed :
$self->{signature_verify} =~ /^NO/
)
and push @e, "Did not pass the signature test.";
}
if (exists $self->{writemakefile} &&
(
UNIVERSAL::can($self->{writemakefile},"failed") ?
$self->{writemakefile}->failed :
$self->{writemakefile} =~ /^NO/
)) {
# XXX maybe a retry would be in order?
my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
$self->{writemakefile}->text :
$self->{writemakefile};
$err =~ s/^NO\s*(--\s+)?//;
$err ||= "Had some problem writing Makefile";
$err .= ", won't make";
push @e, $err;
}
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)
} else {
# introduced for turning recursion detection into a distrostatus
my $error = length $self->{make}>3
? substr($self->{make},3) : "Unknown error";
$CPAN::Frontend->mywarn("Could not make: $error\n");
$self->store_persistent_state;
return;
}
} else {
push @e, "Has already been made";
my $wait_for_prereqs = eval { $self->satisfy_requires };
return 1 if $wait_for_prereqs; # tells queuerunner to continue
return $self->goodbye($@) if $@; # tells queuerunner to stop
}
}
my $later = $self->{later} || $self->{configure_requires_later};
if ($later) { # see also undelay
if ($later) {
push @e, $later;
}
}
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
$builddir = $self->dir or
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
unless (chdir $builddir) {
push @e, "Couldn't chdir to '$builddir': $!";
}
$CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
$CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make($self);
return;
}
my %env;
while (my($k,$v) = each %ENV) {
next unless defined $v;
$env{$k} = $v;
}
local %ENV = %env;
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};
}
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";
$system = "$perl Build.PL $CPAN::Config->{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};
}
if ($pl_env) {
for my $e (keys %$pl_env) {
$ENV{$e} = $pl_env->{$e};
}
}
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) = CPAN::Reporter::record_command($system);
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") {
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
delete $self->{make_clean}; # if cleaned before, enable next
} 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");
}
}
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $wait_for_prereqs = eval { $self->satisfy_requires };
return 1 if $wait_for_prereqs; # tells queuerunner to continue
return $self->goodbye($@) if $@; # tells queuerunner to stop
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $make_commandline;
if ($self->prefs->{make}) {
$make_commandline = $self->prefs->{make}{commandline};
}
if ($make_commandline) {
$system = $make_commandline;
$ENV{PERL} = CPAN::find_perl();
} else {
if ($self->{modulebuild}) {
unless (-f "Build") {
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};
}
if ($make_env) { # overriding the local ENV of PL, not the outer
# ENV, but unlikely to be a risk
for my $e (keys %$make_env) {
$ENV{$e} = $make_env->{$e};
}
}
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;
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 {
$system_ok = system($system) == 0;
}
$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");
}
$self->store_persistent_state;
}
# CPAN::Distribution::goodbye ;
sub goodbye {
my($self,$goodbye) = @_;
my $id = $self->pretty_id;
$CPAN::Frontend->mywarn(" $id\n $goodbye\n");
return;
}
# CPAN::Distribution::_run_via_expect ;
sub _run_via_expect {
my($self,$system,$phase,$expect_model) = @_;
CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
if ($CPAN::META->has_inst("Expect")) {
my $expo = Expect->new; # expo Expect object;
$expo->spawn($system);
$expect_model->{mode} ||= "deterministic";
if ($expect_model->{mode} eq "deterministic") {
return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
} elsif ($expect_model->{mode} eq "anyorder") {
return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
} else {
die "Panic: Illegal expect mode: $expect_model->{mode}";
}
} else {
$CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
return system($system);
}
}
sub _run_via_expect_anyorder {
my($self,$expo,$phase,$expect_model) = @_;
my $timeout = $expect_model->{timeout} || 5;
my $reuse = $expect_model->{reuse};
my @expectacopy = @{$expect_model->{talk}}; # we trash it!
my $but = "";
my $timeout_start = time;
EXPECT: while () {
my($eof,$ran_into_timeout);
# XXX not up to the full power of expect. one could certainly
# wrap all of the talk pairs into a single expect call and on
# success tweak it and step ahead to the next question. The
# current implementation unnecessarily limits itself to a
# single match.
my @match = $expo->expect(1,
[ eof => sub {
$eof++;
} ],
[ timeout => sub {
$ran_into_timeout++;
} ],
-re => eval"qr{.}",
);
if ($match[2]) {
$but .= $match[2];
}
$but .= $expo->clear_accum;
if ($eof) {
$expo->soft_close;
return $expo->exitstatus();
} elsif ($ran_into_timeout) {
# warn "DEBUG: they are asking a question, but[$but]";
for (my $i = 0; $i <= $#expectacopy; $i+=2) {
my($next,$send) = @expectacopy[$i,$i+1];
my $regex = eval "qr{$next}";
# warn "DEBUG: will compare with regex[$regex].";
if ($but =~ /$regex/) {
# warn "DEBUG: will send send[$send]";
$expo->send($send);
# never allow reusing an QA pair unless they told us
splice @expectacopy, $i, 2 unless $reuse;
$but =~ s/(?s:^.*?)$regex//;
$timeout_start = time;
next EXPECT;
}
}
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 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) {
# 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];
} 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);
my $unsat = "Unsatisfied dependencies detected during";
my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
{
my $r = int(($w - length($unsat))/2);
my $l = $w - length($unsat) - $r;
$filler1 = "-"x4 . " "x$l;
$filler2 = " "x$r . "-"x4 . "\n";
}
{
my $r = int(($w - length($pretty_id))/2);
my $l = $w - length($pretty_id) - $r;
$filler3 = "-"x4 . " "x$l;
$filler4 = " "x$r . "-"x4 . "\n";
}
$CPAN::Frontend->
myprint("$filler1 $unsat $filler2".
"$filler3 $pretty_id $filler4".
join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples),
);
my $follow = 0;
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
$follow = 1;
} elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
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;
# color them as dirty
for my $gp (@good_prereq_tuples) {
# warn "calling color_cmd_tmps(0,1)";
my $p = $gp->[0];
my $any = CPAN::Shell->expandany($p);
$self->{$slot . "_for"}{$any->id}++;
if ($any) {
$any->color_cmd_tmps(0,2);
} else {
$CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
$CPAN::Frontend->mysleep(2);
}
}
# queue them and re-queue yourself
CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}},
map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples);
$self->{$slot} = "Delayed until after prerequisites";
return 1; # signal success to the queuerunner
}
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 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,$prereq_pm);
my $prefs_depends = $self->prefs->{depends}||{};
my $feature_depends = $self->_feature_depends();
if ($slot eq "configure_requires_later") {
my $meta_configure_requires = $self->configure_requires();
%merged = (
%{$meta_configure_requires||{}},
%{$prefs_depends->{configure_requires}||{}},
%{$feature_depends->{configure_requires}||{}},
);
if (-f "Build.PL"
&& ! -f "Makefile.PL"
&& ! exists $merged{"Module::Build"}
&& ! $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{"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)) {
$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};
}
}
}
%merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
} else {
die "Panic: illegal slot '$slot'";
}
my(@need);
my @merged = %merged;
CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
NEED: while (my($need_module, $need_version) = each %merged) {
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);
next if $nmo->uptodate;
$inst_file = $nmo->inst_file || '';
$available_file = $nmo->available_file || '';
# if they have not specified a version, we accept any installed one
if ( $available_file
and ( # a few quick shortcurcuits
not defined $need_version
or $need_version eq '0' # "==" would trigger warning when not numeric
or $need_version eq "undef"
)) {
unless ($nmo->inst_deprecated) {
next NEED;
}
}
$available_version = $nmo->available_version;
}
# We only want to install prereqs if either they're not installed
# or if the installed version is too old. We cannot omit this
# check, because if 'force' is in effect, nobody else will check.
# But we don't want to accept a deprecated module installed as part
# of the Perl core, so we continue if the available file is the installed
# one and is deprecated
if ( $available_file ) {
if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) {
# continue installing as a prereq
} elsif ($self->{reqtype} =~ /^(r|c)$/ && exists $prereq_pm->{requires}{$need_module} && $nmo && !$inst_file) {
# continue installing as a prereq; this may be a
# distro we already used when it was a build_requires
# so we did not install it. But suddenly somebody
# wants it as a requires
my $need_distro = $nmo->distribution;
if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) {
CPAN->debug("promotion from build_requires to requires") if $CPAN::DEBUG;
delete $need_distro->{install}; # promote to another installation attempt
$need_distro->{reqtype} = "r";
$need_distro->install;
next NEED;
}
}
else {
next NEED if $self->_fulfills_all_version_rqs(
$need_module,$available_file,$available_version,$need_version
);
}
}
if ($need_module eq "perl") {
return ["perl", $need_version];
}
$self->{sponsored_mods}{$need_module} ||= 0;
CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
# We have already sponsored it and for some reason it's still
# not available. So we do ... what??
# if we push it again, we have a potential infinite loop
# The following "next" was a very problematic construct.
# It helped a lot but broke some day and had to be
# replaced.
# We must be able to deal with modules that come again and
# again as a prereq and have themselves prereqs and the
# queue becomes long but finally we would find the correct
# order. The RecursiveDependency check should trigger a
# die when it's becoming too weird. Unfortunately removing
# this next breaks many other things.
# The bug that brought this up is described in Todo under
# "5.8.9 cannot install Compress::Zlib"
# next; # this is the next that had to go away
# The following "next NEED" are fine and the error message
# explains well what is going on. For example when the DBI
# fails and consequently DBD::SQLite fails and now we are
# processing CPAN::SQLite. Then we must have a "next" for
# DBD::SQLite. How can we get it and how can we identify
# all other cases we must identify?
my $do = $nmo->distribution;
next NEED unless $do; # not on CPAN
if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
$CPAN::Frontend->mywarn("Warning: Prerequisite ".
"'$need_module => $need_version' ".
"for '$self->{ID}' seems ".
"not available according to the indices\n"
);
next NEED;
}
NOSAYER: for my $nosayer (
"unwrapped",
"writemakefile",
"signature_verify",
"make",
"make_test",
"install",
"make_clean",
) {
if ($do->{$nosayer}) {
my $selfid = $self->pretty_id;
my $did = $do->pretty_id;
if (UNIVERSAL::can($do->{$nosayer},"failed") ?
$do->{$nosayer}->failed :
$do->{$nosayer} =~ /^NO/) {
if ($nosayer eq "make_test"
&&
$do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
) {
next NOSAYER;
}
$CPAN::Frontend->mywarn("Warning: Prerequisite ".
"'$need_module => $need_version' ".
"for '$selfid' failed when ".
"processing '$did' with ".
"'$nosayer => $do->{$nosayer}'. Continuing, ".
"but chances to succeed are limited.\n"
);
$CPAN::Frontend->mysleep($sponsoring/10);
next NEED;
} else { # the other guy succeeded
if ($nosayer =~ /^(install|make_test)$/) {
# we had this with
# DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
# in 2007-03 for 'make install'
# and 2008-04: #30464 (for 'make test')
$CPAN::Frontend->mywarn("Warning: Prerequisite ".
"'$need_module => $need_version' ".
"for '$selfid' already built ".
"but the result looks suspicious. ".
"Skipping another build attempt, ".
"to prevent looping endlessly.\n"
);
next NEED;
}
}
}
}
}
my $needed_as;
if (0) {
} elsif (exists $prereq_pm->{requires}{$need_module}) {
$needed_as = "r";
} elsif ($slot eq "configure_requires_later") {
# in ae872487d5 we said: C< we have not yet run the
# {Build,Makefile}.PL, we must presume "r" >; but the
# meta.yml standard says C< These dependencies are not
# required after the distribution is installed. >; so now
# we change it back to "b" and care for the proper
# promotion later.
$needed_as = "b";
} else {
$needed_as = "b";
}
push @need, [$need_module,$needed_as];
}
my @unfolded = map { "[".join(",",@$_)."]" } @need;
CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
@need;
}
sub _fulfills_all_version_rqs {
my($self,$need_module,$available_file,$available_version,$need_version) = @_;
my(@all_requirements) = split /\s*,\s*/, $need_version;
local($^W) = 0;
my $ok = 0;
RQ: for my $rq (@all_requirements) {
if ($rq =~ s|>=\s*||) {
} elsif ($rq =~ s|>\s*||) {
# 2005-12: one user
if (CPAN::Version->vgt($available_version,$rq)) {
$ok++;
}
next RQ;
} elsif ($rq =~ s|!=\s*||) {
# 2005-12: no user
if (CPAN::Version->vcmp($available_version,$rq)) {
$ok++;
next RQ;
} else {
$ok=0;
last RQ;
}
} elsif ($rq =~ m|<=?\s*|) {
# 2005-12: no user
$CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
$ok++;
next RQ;
} elsif ($rq =~ s|==\s*||) {
# 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz
if (CPAN::Version->vcmp($available_version,$rq)) {
$ok=0;
last RQ;
} else {
$ok++;
next RQ;
}
}
if (! CPAN::Version->vgt($rq, $available_version)) {
$ok++;
}
CPAN->debug(sprintf("need_module[%s]available_file[%s]".
"available_version[%s]rq[%s]ok[%d]",
$need_module,
$available_file,
$available_version,
CPAN::Version->readable($rq),
$ok,
)) if $CPAN::DEBUG;
}
my $ret = $ok == @all_requirements;
CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG;
return $ret;
}
#-> sub CPAN::Distribution::read_meta
# read any sort of meta files, return CPAN::Meta object if no errors
sub read_meta {
my($self) = @_;
my $meta_file = $self->pick_meta_file
or return;
return unless $CPAN::META->has_usable("CPAN::Meta");
my $meta = eval { CPAN::Meta->load_file($meta_file)}
or return;
# Very old EU::MM could have wrong META
if ($meta_file eq 'META.yml'
&& $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/
) {
my $eummv = do { local $^W = 0; $1+0; };
return if $eummv < 6.2501;
}
return $meta;
}
#-> sub CPAN::Distribution::read_yaml ;
# XXX This should be DEPRECATED -- dagolden, 2011-02-05
sub read_yaml {
my($self) = @_;
my $meta_file = $self->pick_meta_file;
$self->debug("meta_file[$meta_file]") if $CPAN::DEBUG;
return unless $meta_file;
my $yaml;
eval { $yaml = $self->parse_meta_yml($meta_file) };
if ($@ or ! $yaml) {
return undef; # if we die, then we cannot read YAML's own META.yml
}
# not "authoritative"
if (defined $yaml && (! ref $yaml || ref $yaml ne "HASH")) {
$CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
$yaml = undef;
}
$self->debug(sprintf "yaml[%s]", $yaml || "UNDEF")
if $CPAN::DEBUG;
$self->debug($yaml) if $CPAN::DEBUG && $yaml;
# MYMETA.yml is static and authoritative by definition
if ( $meta_file =~ /MYMETA\.yml/ ) {
return $yaml;
}
# META.yml is authoritative only if dynamic_config is defined and false
if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
return $yaml;
}
# otherwise, we can't use what we found
return undef;
}
#-> sub CPAN::Distribution::configure_requires ;
sub configure_requires {
my($self) = @_;
return unless my $meta_file = $self->pick_meta_file('^META');
if (my $meta_obj = $self->read_meta) {
my $prereqs = $meta_obj->effective_prereqs;
my $cr = $prereqs->requirements_for(qw/configure requires/);
return $cr ? $cr->as_string_hash : undef;
}
else {
my $yaml = eval { $self->parse_meta_yml($meta_file) };
return $yaml->{configure_requires};
}
}
#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
my($self) = @_;
return unless $self->{writemakefile} # no need to have succeeded
# but we must have run it
|| $self->{modulebuild};
unless ($self->{build_dir}) {
return;
}
CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
$self->{writemakefile}||"",
$self->{modulebuild}||"",
) if $CPAN::DEBUG;
my($req,$breq);
my $meta_obj = $self->read_meta;
# META/MYMETA is only authoritative if dynamic_config is false
if ($meta_obj && ! $meta_obj->dynamic_config) {
my $prereqs = $meta_obj->effective_prereqs;
my $requires = $prereqs->requirements_for(qw/runtime requires/);
my $build_requires = $prereqs->requirements_for(qw/build requires/);
my $test_requires = $prereqs->requirements_for(qw/test requires/);
# XXX we don't yet distinguish build vs test, so merge them for now
$build_requires->add_requirements($test_requires);
$req = $requires->as_string_hash;
$breq = $build_requires->as_string_hash;
}
elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
$req = $yaml->{requires} || {};
$breq = $yaml->{build_requires} || {};
undef $req unless ref $req eq "HASH" && %$req;
if ($req) {
if ($yaml->{generated_by} &&
$yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
my $eummv = do { local $^W = 0; $1+0; };
if ($eummv < 6.2501) {
# thanks to Slaven for digging that out: MM before
# that could be wrong because it could reflect a
# previous release
undef $req;
}
}
my $areq;
my $do_replace;
while (my($k,$v) = each %{$req||{}}) {
next unless defined $v;
if ($v =~ /\d/) {
$areq->{$k} = $v;
} elsif ($k =~ /[A-Za-z]/ &&
$v =~ /[A-Za-z]/ &&
$CPAN::META->exists("CPAN::Module",$v)
) {
$CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
"requires hash: $k => $v; I'll take both ".
"key and value as a module name\n");
$CPAN::Frontend->mysleep(1);
$areq->{$k} = 0;
$areq->{$v} = 0;
$do_replace++;
}
}
$req = $areq if $do_replace;
}
}
else {
$CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ".
"methods to determine prerequisites\n");
}
unless ($req || $breq) {
my $build_dir;
unless ( $build_dir = $self->{build_dir} ) {
return;
}
my $makefile = File::Spec->catfile($build_dir,"Makefile");
my $fh;
if (-f $makefile
and
$fh = FileHandle->new("<$makefile\0")) {
CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
local($/) = "\n";
while (<$fh>) {
last if /MakeMaker post_initialize section/;
my($p) = m{^[\#]
\s+PREREQ_PM\s+=>\s+(.+)
}x;
next unless $p;
# warn "Found prereq expr[$p]";
# Regexp modified by A.Speer to remember actual version of file
# PREREQ_PM hash key wants, then add to
while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
my($m,$n) = ($1,$2);
# When a prereq is mentioned twice: let the bigger
# win; usual culprit is that they declared
# build_requires separately from requires; see
# rt.cpan.org #47774
my($prevn);
if ( defined $req->{$m} ) {
$prevn = $req->{$m};
}
if ($n =~ /^q\[(.*?)\]$/) {
$n = $1;
}
if (!$prevn || CPAN::Version->vlt($prevn, $n)){
$req->{$m} = $n;
}
}
last;
}
}
}
unless ($req || $breq) {
my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
my $buildfile = File::Spec->catfile($build_dir,"Build");
if (-f $buildfile) {
CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
if (-f $build_prereqs) {
CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
my $content = do { local *FH;
open FH, $build_prereqs
or $CPAN::Frontend->mydie("Could not open ".
"'$build_prereqs': $!");
local $/;
<FH>;
};
my $bphash = eval $content;
if ($@) {
} else {
$req = $bphash->{requires} || +{};
$breq = $bphash->{build_requires} || +{};
}
}
}
}
if ($req || $breq) {
return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
}
}
#-> sub CPAN::Distribution::test ;
sub test {
my($self) = @_;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
$self->make;
return if $self->prefs->{disabled} && ! $self->{force_update};
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
# warn "XDEBUG: checking for notest: $self->{notest} $self";
if ($self->{notest}) {
$CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
return 1;
}
my $make = $self->{modulebuild} ? "Build" : "make";
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
local $ENV{MAKEFLAGS}; # protect us from outer make calls
$CPAN::Frontend->myprint("Running $make test\n");
EXCUSE: {
my @e;
if ($self->{make} or $self->{later}) {
# go ahead
} else {
push @e,
"Make had some problems, won't test";
}
exists $self->{make} and
(
UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) and push @e, "Can't test without successful make";
$self->{badtestcnt} ||= 0;
if ($self->{badtestcnt} > 0) {
require Data::Dumper;
CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
push @e, "Won't repeat unsuccessful test during this command";
}
push @e, $self->{later} if $self->{later};
push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
if (exists $self->{build_dir}) {
if (exists $self->{make_test}) {
if (
UNIVERSAL::can($self->{make_test},"failed") ?
$self->{make_test}->failed :
$self->{make_test} =~ /^NO/
) {
if (
UNIVERSAL::can($self->{make_test},"commandid")
&&
$self->{make_test}->commandid == $CPAN::CurrentCommandId
) {
push @e, "Has already been tested within this command";
}
} else {
push @e, "Has already been tested successfully";
# 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});
}
}
}
} elsif (!@e) {
push @e, "Has no own directory";
}
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
unless (chdir $self->{build_dir}) {
push @e, "Couldn't chdir to '$self->{build_dir}': $!";
}
$CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_test($self);
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");
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");
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");
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") {
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 %env;
while (my($k,$v) = each %ENV) {
next unless defined $v;
$env{$k} = $v;
}
local %ENV = %env;
my $test_env;
if ($self->prefs->{test}) {
$test_env = $self->prefs->{test}{env};
}
if ($test_env) {
for my $e (keys %$test_env) {
$ENV{$e} = $test_env->{$e};
}
}
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");
}
}
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");
}
$tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
} elsif ( $self->_should_report('test') ) {
$tests_ok = CPAN::Reporter::test($self, $system);
} else {
$tests_ok = system($system) == 0;
}
$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;
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");
} 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;
}
sub _make_test_illuminate_prereqs {
my($self) = @_;
my @prereq;
# local $CPAN::DEBUG = 16; # Distribution
for my $m (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;
}
}
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("Running $make clean\n");
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::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];
CPAN->instance("CPAN::Distribution",$goto)->$method();
CPAN::Queue->delete_first($goto);
}
#-> sub CPAN::Distribution::install ;
sub install {
my($self) = @_;
if (my $goto = $self->prefs->{goto}) {
return $self->goto($goto);
}
unless ($self->{badtestcnt}) {
$self->test;
}
if ($CPAN::Signal) {
delete $self->{force_update};
return;
}
my $make = $self->{modulebuild} ? "Build" : "make";
$CPAN::Frontend->myprint("Running $make install\n");
EXCUSE: {
my @e;
if ($self->{make} or $self->{later}) {
# go ahead
} else {
push @e,
"Make had some problems, won't install";
}
exists $self->{make} and
(
UNIVERSAL::can($self->{make},"failed") ?
$self->{make}->failed :
$self->{make} =~ /^NO/
) and
push @e, "Make had returned bad status, install seems impossible";
if (exists $self->{build_dir}) {
} elsif (!@e) {
push @e, "Has no own directory";
}
if (exists $self->{make_test} and
(
UNIVERSAL::can($self->{make_test},"failed") ?
$self->{make_test}->failed :
$self->{make_test} =~ /^NO/
)) {
if ($self->{force_update}) {
$self->{make_test}->text("FAILED but failure ignored because ".
"'force' in effect");
} else {
push @e, "make test had returned bad status, ".
"won't install without force"
}
}
if (exists $self->{install}) {
my $text = UNIVERSAL::can($self->{install},"text") ?
$self->{install}->text :
$self->{install};
if ($text =~ /^YES/) {
$CPAN::Frontend->myprint(" Already done\n");
$CPAN::META->is_installed($self->{build_dir});
return 1;
} elsif ($text =~ /is only/) {
push @e, $text;
} else {
# comment in Todo on 2006-02-11; maybe retry?
push @e, "Already tried without success";
}
}
push @e, $self->{later} if $self->{later};
push @e, $self->{configure_requires_later} if $self->{configure_requires_later};
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
unless (chdir $self->{build_dir}) {
push @e, "Couldn't chdir to '$self->{build_dir}': $!";
}
$CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e;
}
$self->debug("Changed directory to $self->{build_dir}")
if $CPAN::DEBUG;
if ($^O eq 'MacOS') {
Mac::BuildTools::make_install($self);
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();
$system = sprintf("%s install %s",
$mbuild_install_build_command,
$CPAN::Config->{mbuild_install_arg},
);
} else {
my($make_install_make_command) =
CPAN::HandleConfig->prefs_lookup($self,
q{make_install_make_command})
|| $self->_make_command();
$system = sprintf("%s install %s",
$make_install_make_command,
$CPAN::Config->{make_install_arg},
);
}
my($stderr) = $^O eq "MSWin32" ? "" : " 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'";
$CPAN::Frontend->mywarn("Not installing because $is_only\n");
$self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
delete $self->{force_update};
return;
}
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
? $ENV{PERL5LIB}
: ($ENV{PERLLIB} || "");
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
$CPAN::META->set_perl5lib;
my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak
("Can't execute $system: $!");
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");
} 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};
$self->store_persistent_state;
}
sub introduce_myself {
my($self) = @_;
$CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id));
}
#-> sub CPAN::Distribution::dir ;
sub dir {
shift->{build_dir};
}
#-> sub CPAN::Distribution::perldoc ;
sub perldoc {
my($self) = @_;
my($dist) = $self->id;
my $package = $self->called_for;
if ($CPAN::META->has_inst("Pod::Perldocs")) {
my($perl) = $self->perl
or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
my @args = ($perl, q{-MPod::Perldocs}, q{-e},
q{Pod::Perldocs->run()}, $package);
my($wstatus);
unless ( ($wstatus = system(@args)) == 0 ) {
my $estatus = $wstatus >> 8;
$CPAN::Frontend->myprint(qq{
Function system("@args")
returned status $estatus (wstat $wstatus)
});
}
}
else {
$self->_display_url( $CPAN::Defaultdocs . $package );
}
}
#-> sub CPAN::Distribution::_check_binary ;
sub _check_binary {
my ($dist,$shell,$binary) = @_;
my ($pid,$out);
$CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
if $CPAN::DEBUG;
if ($CPAN::META->has_inst("File::Which")) {
return File::Which::which($binary);
} else {
local *README;
$pid = open README, "which $binary|"
or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
return unless $pid;
while (<README>) {
$out .= $_;
}
close README
or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
and return;
}
$CPAN::Frontend->myprint(qq{ + $out \n})
if $CPAN::DEBUG && $out;
return $out;
}
#-> sub CPAN::Distribution::_display_url ;
sub _display_url {
my($self,$url) = @_;
my($res,$saved_file,$pid,$out);
$CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
if $CPAN::DEBUG;
# should we define it in the config instead?
my $html_converter = "html2text.pl";
my $web_browser = $CPAN::Config->{'lynx'} || undef;
my $web_browser_out = $web_browser
? CPAN::Distribution->_check_binary($self,$web_browser)
: undef;
if ($web_browser_out) {
# web browser found, run the action
my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
$CPAN::Frontend->myprint(qq{system[$browser $url]})
if $CPAN::DEBUG;
$CPAN::Frontend->myprint(qq{
Displaying URL
$url
with browser $browser
});
$CPAN::Frontend->mysleep(1);
system("$browser $url");
if ($saved_file) { 1 while unlink($saved_file) }
} else {
# web browser not found, let's try text only
my $html_converter_out =
CPAN::Distribution->_check_binary($self,$html_converter);
$html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
if ($html_converter_out ) {
# html2text found, run it
$saved_file = CPAN::Distribution->_getsave_url( $self, $url );
$CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
unless defined($saved_file);
local *README;
$pid = open README, "$html_converter $saved_file |"
or $CPAN::Frontend->mydie(qq{
Could not fork '$html_converter $saved_file': $!});
my($fh,$filename);
if ($CPAN::META->has_usable("File::Temp")) {
$fh = File::Temp->new(
dir => File::Spec->tmpdir,
template => 'cpan_htmlconvert_XXXX',
suffix => '.txt',
unlink => 0,
);
$filename = $fh->filename;
} else {
$filename = "cpan_htmlconvert_$$.txt";
$fh = FileHandle->new();
open $fh, ">$filename" or die;
}
while (<README>) {
$fh->print($_);
}
close README or
$CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
my $tmpin = $fh->filename;
$CPAN::Frontend->myprint(sprintf(qq{
Run '%s %s' and
saved output to %s\n},
$html_converter,
$saved_file,
$tmpin,
)) if $CPAN::DEBUG;
close $fh;
local *FH;
open FH, $tmpin
or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
my $fh_pager = FileHandle->new;
local($SIG{PIPE}) = "IGNORE";
my $pager = $CPAN::Config->{'pager'} || "cat";
$fh_pager->open("|$pager")
or $CPAN::Frontend->mydie(qq{
Could not open pager '$pager': $!});
$CPAN::Frontend->myprint(qq{
Displaying URL
$url
with pager "$pager"
});
$CPAN::Frontend->mysleep(1);
$fh_pager->print(<FH>);
$fh_pager->close;
} else {
# coldn't find the web browser or html converter
$CPAN::Frontend->myprint(qq{
You need to install lynx or $html_converter to use this feature.});
}
}
}
#-> sub CPAN::Distribution::_getsave_url ;
sub _getsave_url {
my($dist, $shell, $url) = @_;
$CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
if $CPAN::DEBUG;
my($fh,$filename);
if ($CPAN::META->has_usable("File::Temp")) {
$fh = File::Temp->new(
dir => File::Spec->tmpdir,
template => "cpan_getsave_url_XXXX",
suffix => ".html",
unlink => 0,
);
$filename = $fh->filename;
} else {
$fh = FileHandle->new;
$filename = "cpan_getsave_url_$$.html";
}
my $tmpin = $filename;
if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
");
my $Ua;
CPAN::LWP::UserAgent->config;
eval { $Ua = CPAN::LWP::UserAgent->new; };
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";
}
return "./Build";
}
#-> sub CPAN::Distribution::_should_report
sub _should_report {
my($self, $phase) = @_;
die "_should_report() requires a 'phase' argument"
if ! defined $phase;
# 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 $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.yaml", $dist;
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);
}
$CPAN::Frontend->myprint("DONE\n\n");
my $yaml = $resp->content;
# was fuer ein Umweg!
my $fh = File::Temp->new(
dir => File::Spec->tmpdir,
template => 'cpan_reports_XXXX',
suffix => '.yaml',
unlink => 0,
);
my $tfilename = $fh->filename;
print $fh $yaml;
close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
my %other_versions;
my $this_version_seen;
for my $rep (@$unserialized) {
my $rversion = $rep->{version};
if ($rversion eq $version) {
unless ($this_version_seen++) {
$CPAN::Frontend->myprint ("$rep->{version}:\n");
}
my $arch = $rep->{archname} || $rep->{platform} || '????';
my $grade = $rep->{action} || $rep->{status} || '????';
my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????';
$CPAN::Frontend->myprint
(sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
$arch eq $Config::Config{archname}?"*":"",
$grade eq "PASS"?"+":$grade eq"FAIL"?"-":"",
$grade,
$rep->{perl},
$ostext,
$rep->{osvers},
$arch,
));
} else {
$other_versions{$rep->{version}}++;
}
}
unless ($this_version_seen) {
$CPAN::Frontend->myprint("No reports found for version '$version'
Reports for other versions:\n");
for my $v (sort keys %other_versions) {
$CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
}
}
$url =~ s/\.yaml/.html/;
$CPAN::Frontend->myprint("See $url for details\n");
}
1;