4863 lines
176 KiB
Perl
4863 lines
176 KiB
Perl
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
|
|
# vim: ts=4 sts=4 sw=4:
|
|
package CPAN::Distribution;
|
|
use strict;
|
|
use Cwd qw(chdir);
|
|
use CPAN::Distroprefs;
|
|
use CPAN::InfoObj;
|
|
use File::Path ();
|
|
use POSIX ":sys_wait_h";
|
|
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
|
|
use vars qw($VERSION);
|
|
$VERSION = "2.27";
|
|
|
|
my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option
|
|
|
|
# no prepare, because prepare is not a command on the shell command line
|
|
# TODO: clear instance cache on reload
|
|
my %instance;
|
|
for my $method (qw(get make test install)) {
|
|
no strict 'refs';
|
|
for my $prefix (qw(pre post)) {
|
|
my $hookname = sprintf "%s_%s", $prefix, $method;
|
|
*$hookname = sub {
|
|
my($self) = @_;
|
|
for my $plugin (@{$CPAN::Config->{plugin_list}}) {
|
|
my($plugin_proper,$args) = split /=/, $plugin, 2;
|
|
$args = "" unless defined $args;
|
|
if ($CPAN::META->has_inst($plugin_proper)){
|
|
my @args = split /,/, $args;
|
|
$instance{$plugin} ||= $plugin_proper->new(@args);
|
|
if ($instance{$plugin}->can($hookname)) {
|
|
$instance{$plugin}->$hookname($self);
|
|
}
|
|
} else {
|
|
$CPAN::Frontend->mydie("Plugin '$plugin_proper' not found for hook '$hookname'");
|
|
}
|
|
}
|
|
};
|
|
}
|
|
}
|
|
|
|
# Accessors
|
|
sub cpan_comment {
|
|
my $self = shift;
|
|
my $ro = $self->ro or return;
|
|
$ro->{CPAN_COMMENT}
|
|
}
|
|
|
|
#-> CPAN::Distribution::undelay
|
|
sub undelay {
|
|
my $self = shift;
|
|
for my $delayer (
|
|
"configure_requires_later",
|
|
"configure_requires_later_for",
|
|
"later",
|
|
"later_for",
|
|
) {
|
|
delete $self->{$delayer};
|
|
}
|
|
}
|
|
|
|
#-> CPAN::Distribution::is_dot_dist
|
|
sub is_dot_dist {
|
|
my($self) = @_;
|
|
return substr($self->id,-1,1) eq ".";
|
|
}
|
|
|
|
# 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-0-9]{2}/[A-Z-0-9]{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;
|
|
$CPAN::MAX_RECURSION||=0; # silence 'once' warnings
|
|
if ($depth>=$CPAN::MAX_RECURSION) {
|
|
my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
|
|
if ($e->is_resolvable) {
|
|
return $self->{incommandcolor}=2;
|
|
} else {
|
|
die $e;
|
|
}
|
|
}
|
|
# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
|
|
my $prereq_pm = $self->prereq_pm;
|
|
if (defined $prereq_pm) {
|
|
# XXX also optional_req & optional_breq? -- xdg, 2012-04-01
|
|
# A: no, optional deps may recurse -- ak, 2014-05-07
|
|
PREREQ: for my $pre (sort(
|
|
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 sort 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;
|
|
}
|
|
sort 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::shortcut_get ;
|
|
# return values: undef means don't shortcut; 0 means shortcut as fail;
|
|
# and 1 means shortcut as success
|
|
sub shortcut_get {
|
|
my ($self) = @_;
|
|
|
|
if (exists $self->{cleanup_after_install_done}) {
|
|
if ($self->{force_update}) {
|
|
delete $self->{cleanup_after_install_done};
|
|
} else {
|
|
my $id = $self->{CALLED_FOR} || $self->pretty_id;
|
|
return $self->success(
|
|
"Has already been *installed and cleaned up in the staging area* within this session, will not work on it again; if you really want to start over, try something like `force get $id`"
|
|
);
|
|
}
|
|
}
|
|
|
|
if (my $why = $self->check_disabled) {
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
|
|
# XXX why is this goodbye() instead of just print/warn?
|
|
# Alternatively, should other print/warns here be goodbye()?
|
|
# -- xdg, 2012-04-05
|
|
return $self->goodbye("[disabled] -- NA $why");
|
|
}
|
|
|
|
$self->debug("checking already unwrapped[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (exists $self->{build_dir} && -d $self->{build_dir}) {
|
|
# this deserves print, not warn:
|
|
return $self->success("Has already been unwrapped into directory ".
|
|
"$self->{build_dir}"
|
|
);
|
|
}
|
|
|
|
# XXX I'm not sure this should be here because it's not really
|
|
# a test for whether get should continue or return; this is
|
|
# a side effect -- xdg, 2012-04-05
|
|
$self->debug("checking missing build_dir[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (exists $self->{build_dir} && ! -d $self->{build_dir}){
|
|
# we have lost it.
|
|
$self->fforce(""); # no method to reset all phases but not set force (dodge)
|
|
return undef; # no shortcut
|
|
}
|
|
|
|
# although we talk about 'force' we shall not test on
|
|
# force directly. New model of force tries to refrain from
|
|
# direct checking of force.
|
|
$self->debug("checking unwrapping error[$self->{ID}]") if $CPAN::DEBUG;
|
|
if ( exists $self->{unwrapped} and (
|
|
UNIVERSAL::can($self->{unwrapped},"failed") ?
|
|
$self->{unwrapped}->failed :
|
|
$self->{unwrapped} =~ /^NO/ )
|
|
) {
|
|
return $self->goodbye("Unwrapping had some problem, won't try again without force");
|
|
}
|
|
|
|
return undef; # no shortcut
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::get ;
|
|
sub get {
|
|
my($self) = @_;
|
|
|
|
$self->pre_get();
|
|
|
|
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (my $goto = $self->prefs->{goto}) {
|
|
$self->post_get();
|
|
return $self->goto($goto);
|
|
}
|
|
|
|
if ( defined( my $sc = $self->shortcut_get) ) {
|
|
$self->post_get();
|
|
return $sc;
|
|
}
|
|
|
|
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
|
|
? $ENV{PERL5LIB}
|
|
: ($ENV{PERLLIB} || "");
|
|
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
|
|
# local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # get
|
|
$CPAN::META->set_perl5lib;
|
|
local $ENV{MAKEFLAGS}; # protect us from outer make calls
|
|
|
|
my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
|
|
|
|
my($local_file);
|
|
# XXX I don't think this check needs to be here, as it
|
|
# is already checked in shortcut_get() -- xdg, 2012-04-05
|
|
unless ($self->{build_dir} && -d $self->{build_dir}) {
|
|
$self->get_file_onto_local_disk;
|
|
if ($CPAN::Signal){
|
|
$self->post_get();
|
|
return;
|
|
}
|
|
$self->check_integrity;
|
|
if ($CPAN::Signal){
|
|
$self->post_get();
|
|
return;
|
|
}
|
|
(my $packagedir,$local_file) = $self->run_preps_on_packagedir;
|
|
# XXX why is this check here? -- xdg, 2012-04-08
|
|
if (exists $self->{writemakefile} && ref $self->{writemakefile}
|
|
&& $self->{writemakefile}->can("failed") &&
|
|
$self->{writemakefile}->failed) {
|
|
#
|
|
$self->post_get();
|
|
return;
|
|
}
|
|
$packagedir ||= $self->{build_dir};
|
|
$self->{build_dir} = $packagedir;
|
|
}
|
|
|
|
# XXX should this move up to after run_preps_on_packagedir?
|
|
# Otherwise, failing writemakefile can return without
|
|
# a $CPAN::Signal check -- xdg, 2012-04-05
|
|
if ($CPAN::Signal) {
|
|
$self->safe_chdir($sub_wd);
|
|
$self->post_get();
|
|
return;
|
|
}
|
|
unless ($self->patch){
|
|
$self->post_get();
|
|
return;
|
|
}
|
|
$self->store_persistent_state;
|
|
|
|
$self->post_get();
|
|
|
|
return 1; # success
|
|
}
|
|
|
|
#-> 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 $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($mode) = (stat $from_dir)[2];
|
|
chmod $mode | 00755, $from_dir; # JONATHAN/Math-Calculus-TaylorSeries-0.1.tar.gz has 0644
|
|
my $dh2;
|
|
unless ($dh2 = DirHandle->new($from_dir)) {
|
|
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;
|
|
}
|
|
my $packagedir;
|
|
my $eexist = ($CPAN::META->has_usable("Errno") && defined &Errno::EEXIST)
|
|
? &Errno::EEXIST : undef;
|
|
for(my $suffix = 0; ; $suffix++) {
|
|
$packagedir = File::Spec->catdir($builddir, "$tdir_base-$suffix");
|
|
my $parent = $builddir;
|
|
mkdir($packagedir, 0777) and last;
|
|
if((defined($eexist) && $! != $eexist) || $suffix == 999) {
|
|
$CPAN::Frontend->mydie("Cannot create directory $packagedir: $!\n");
|
|
}
|
|
}
|
|
my $f;
|
|
for $f (@dirents) { # is already without "." and ".."
|
|
my $from = File::Spec->catfile($from_dir,$f);
|
|
my($mode) = (stat $from)[2];
|
|
chmod $mode | 00755, $from if -d $from; # OTTO/Pod-Trial-LinkImg-0.005.tgz
|
|
my $to = File::Spec->catfile($packagedir,$f);
|
|
unless (File::Copy::move($from,$to)) {
|
|
my $err = $!;
|
|
$from = File::Spec->rel2abs($from);
|
|
$CPAN::Frontend->mydie(
|
|
"Couldn't move $from to $to: $err; #82295? ".
|
|
"CPAN::VERSION=$CPAN::VERSION; ".
|
|
"File::Copy::VERSION=$File::Copy::VERSION; ".
|
|
"$from " . (-e $from ? "exists; " : "does not exist; ").
|
|
"$to " . (-e $to ? "exists; " : "does not exist; ").
|
|
"cwd=" . CPAN::anycwd() . ";"
|
|
);
|
|
}
|
|
}
|
|
$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->catfile( $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;
|
|
if (!ref $early_yaml or ref $early_yaml ne "HASH"){
|
|
# fix rt.cpan.org #95271
|
|
$CPAN::Frontend->mywarn("The content of '$yaml' is not a HASH reference. Cannot use it.\n");
|
|
return {};
|
|
}
|
|
return $early_yaml || undef;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::satisfy_requires ;
|
|
# return values: 1 means requirements are satisfied;
|
|
# and 0 means not satisfied (and maybe queued)
|
|
sub satisfy_requires {
|
|
my ($self) = @_;
|
|
$self->debug("Entering satisfy_requires") if $CPAN::DEBUG;
|
|
if (my @prereq = $self->unsat_prereq("later")) {
|
|
if ($CPAN::DEBUG){
|
|
require Data::Dumper;
|
|
my $prereq = Data::Dumper->new(\@prereq)->Terse(1)->Indent(0)->Dump;
|
|
$self->debug("unsatisfied[$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) {
|
|
return; # we need deps
|
|
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
|
|
$CPAN::Frontend->mywarn($@);
|
|
die "[depend] -- NOT OK\n";
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::satisfy_configure_requires ;
|
|
# return values: 1 means configure_require is satisfied;
|
|
# and 0 means not satisfied (and maybe queued)
|
|
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 (sort keys %{$self->{configure_requires_later_for}||{}}) {
|
|
if ($self->{configure_requires_later_for}{$k}>1) {
|
|
my $type = "";
|
|
for my $p (@prereq) {
|
|
if ($p->[0] eq $k) {
|
|
$type = $p->[1];
|
|
}
|
|
}
|
|
$type = " $type" if $type;
|
|
$CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type");
|
|
sleep 1;
|
|
}
|
|
}
|
|
}
|
|
if ($prereq[0][0] eq "perl") {
|
|
my $need = "requires perl '$prereq[0][1]'";
|
|
my $id = $self->pretty_id;
|
|
$CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
|
|
$self->{make} = CPAN::Distrostatus->new("NO $need");
|
|
$self->store_persistent_state;
|
|
return $self->goodbye("[prereq] -- NOT OK");
|
|
} else {
|
|
my $follow = eval {
|
|
$self->follow_prereqs("configure_requires_later", @prereq);
|
|
};
|
|
if (0) {
|
|
} elsif ($follow) {
|
|
return; # we need deps
|
|
} elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
|
|
$CPAN::Frontend->mywarn($@);
|
|
return $self->goodbye("[depend] -- NOT OK");
|
|
}
|
|
else {
|
|
return $self->goodbye("[configure_requires] -- NOT OK");
|
|
}
|
|
}
|
|
die "never reached";
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::choose_MM_or_MB ;
|
|
sub choose_MM_or_MB {
|
|
my($self) = @_;
|
|
$self->satisfy_configure_requires() or return;
|
|
my $local_file = $self->{localfile};
|
|
my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
|
|
my($mpl_exists) = -f $mpl;
|
|
unless ($mpl_exists) {
|
|
# NFS has been reported to have racing problems after the
|
|
# renaming of a directory in some environments.
|
|
# This trick helps.
|
|
$CPAN::Frontend->mysleep(1);
|
|
my $mpldh = DirHandle->new($self->{build_dir})
|
|
or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
|
|
$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
|
|
$mpldh->close;
|
|
}
|
|
my $prefer_installer = "eumm"; # eumm|mb
|
|
if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
|
|
if ($mpl_exists) { # they *can* choose
|
|
if ($CPAN::META->has_inst("Module::Build")) {
|
|
$prefer_installer = CPAN::HandleConfig->prefs_lookup(
|
|
$self, q{prefer_installer}
|
|
);
|
|
# M::B <= 0.35 left a DATA handle open that
|
|
# causes problems upgrading M::B on Windows
|
|
close *Module::Build::Version::DATA
|
|
if fileno *Module::Build::Version::DATA;
|
|
}
|
|
} else {
|
|
$prefer_installer = "mb";
|
|
}
|
|
}
|
|
if (lc($prefer_installer) eq "rand") {
|
|
$prefer_installer = rand()<.5 ? "eumm" : "mb";
|
|
}
|
|
if (lc($prefer_installer) eq "mb") {
|
|
$self->{modulebuild} = 1;
|
|
} elsif ($self->{archived} eq "patch") {
|
|
# not an edge case, nothing to install for sure
|
|
my $why = "A patch file cannot be installed";
|
|
$CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
|
|
$self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
|
|
} elsif (! $mpl_exists) {
|
|
$self->_edge_cases($mpl,$local_file);
|
|
}
|
|
if ($self->{build_dir}
|
|
&&
|
|
$CPAN::Config->{build_dir_reuse}
|
|
) {
|
|
$self->store_persistent_state;
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
# see also reanimate_build_dir
|
|
#-> CPAN::Distribution::store_persistent_state
|
|
sub store_persistent_state {
|
|
my($self) = @_;
|
|
my $dir = $self->{build_dir};
|
|
unless (defined $dir && length $dir) {
|
|
my $id = $self->id;
|
|
$CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
|
|
"will not store persistent state\n");
|
|
return;
|
|
}
|
|
# self-build-dir
|
|
my $sbd = Cwd::realpath(
|
|
File::Spec->catdir($dir, File::Spec->updir ())
|
|
);
|
|
# config-build-dir
|
|
my $cbd = Cwd::realpath(
|
|
# the catdir is a workaround for bug https://rt.cpan.org/Ticket/Display.html?id=101283
|
|
File::Spec->catdir($CPAN::Config->{build_dir}, File::Spec->curdir())
|
|
);
|
|
unless ($sbd eq $cbd) {
|
|
$CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
|
|
"will not store persistent state\n");
|
|
return;
|
|
}
|
|
my $file = sprintf "%s.yml", $dir;
|
|
my $yaml_module = CPAN::_yaml_module();
|
|
if ($CPAN::META->has_inst($yaml_module)) {
|
|
CPAN->_yaml_dumpfile(
|
|
$file,
|
|
{
|
|
time => time,
|
|
perl => CPAN::_perl_fingerprint(),
|
|
distribution => $self,
|
|
}
|
|
);
|
|
} else {
|
|
$CPAN::Frontend->myprintonce("'$yaml_module' not installed, ".
|
|
"will not store persistent state\n");
|
|
}
|
|
}
|
|
|
|
#-> CPAN::Distribution::try_download
|
|
sub try_download {
|
|
my($self,$patch) = @_;
|
|
my $norm = $self->normalize($patch);
|
|
my($local_wanted) =
|
|
File::Spec->catfile(
|
|
$CPAN::Config->{keep_source_where},
|
|
"authors",
|
|
"id",
|
|
split(/\//,$norm),
|
|
);
|
|
$self->debug("Doing localize") if $CPAN::DEBUG;
|
|
return CPAN::FTP->localize("authors/id/$norm",
|
|
$local_wanted);
|
|
}
|
|
|
|
{
|
|
my $stdpatchargs = "";
|
|
#-> CPAN::Distribution::patch
|
|
sub patch {
|
|
my($self) = @_;
|
|
$self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
|
|
my $patches = $self->prefs->{patches};
|
|
$patches ||= "";
|
|
$self->debug("patches[$patches]") if $CPAN::DEBUG;
|
|
if ($patches) {
|
|
return unless @$patches;
|
|
$self->safe_chdir($self->{build_dir});
|
|
CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
|
|
my $patchbin = $CPAN::Config->{patch};
|
|
unless ($patchbin && length $patchbin) {
|
|
$CPAN::Frontend->mydie("No external patch command configured\n\n".
|
|
"Please run 'o conf init /patch/'\n\n");
|
|
}
|
|
unless (MM->maybe_command($patchbin)) {
|
|
$CPAN::Frontend->mydie("No external patch command available\n\n".
|
|
"Please run 'o conf init /patch/'\n\n");
|
|
}
|
|
$patchbin = CPAN::HandleConfig->safe_quote($patchbin);
|
|
local $ENV{PATCH_GET} = 0; # formerly known as -g0
|
|
unless ($stdpatchargs) {
|
|
my $system = "$patchbin --version |";
|
|
local *FH;
|
|
open FH, $system or die "Could not fork '$system': $!";
|
|
local $/ = "\n";
|
|
my $pversion;
|
|
PARSEVERSION: while (<FH>) {
|
|
if (/^patch\s+([\d\.]+)/) {
|
|
$pversion = $1;
|
|
last PARSEVERSION;
|
|
}
|
|
}
|
|
if ($pversion) {
|
|
$stdpatchargs = "-N --fuzz=3";
|
|
} else {
|
|
$stdpatchargs = "-N";
|
|
}
|
|
}
|
|
my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
|
|
$CPAN::Frontend->myprint("Applying $countedpatches:\n");
|
|
my $patches_dir = $CPAN::Config->{patches_dir};
|
|
for my $patch (@$patches) {
|
|
if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
|
|
my $f = File::Spec->catfile($patches_dir, $patch);
|
|
$patch = $f if -f $f;
|
|
}
|
|
unless (-f $patch) {
|
|
CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG;
|
|
if (my $trydl = $self->try_download($patch)) {
|
|
$patch = $trydl;
|
|
} else {
|
|
my $fail = "Could not find patch '$patch'";
|
|
$CPAN::Frontend->mywarn("$fail; cannot continue\n");
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
|
|
delete $self->{build_dir};
|
|
return;
|
|
}
|
|
}
|
|
$CPAN::Frontend->myprint(" $patch\n");
|
|
my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
|
|
|
|
my $pcommand;
|
|
my($ppp,$pfiles) = $self->_patch_p_parameter($readfh);
|
|
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";
|
|
# parse name and 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 {
|
|
# unfortunately we have no $@ here, Tarzip is using mydie which dies with "\n"
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
|
|
}
|
|
}
|
|
|
|
# CPAN::Distribution::unzip_me ;
|
|
sub unzip_me {
|
|
my($self,$ct) = @_;
|
|
$self->{archived} = "zip";
|
|
if (eval { $ct->unzip() }) {
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("YES");
|
|
} else {
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed during unzip");
|
|
}
|
|
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} : "";
|
|
# local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # look
|
|
$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",
|
|
"cleanup_after_install_done",
|
|
],
|
|
make => [
|
|
"writemakefile",
|
|
"make",
|
|
"modulebuild",
|
|
"prereq_pm",
|
|
"cleanup_after_install_done",
|
|
],
|
|
test => [
|
|
"badtestcnt",
|
|
"make_test",
|
|
"cleanup_after_install_done",
|
|
],
|
|
install => [
|
|
"install",
|
|
"cleanup_after_install_done",
|
|
],
|
|
unknown => [
|
|
"reqtype",
|
|
"yaml_content",
|
|
"cleanup_after_install_done",
|
|
],
|
|
);
|
|
my $methodmatch = 0;
|
|
my $ldebug = 0;
|
|
PHASE: for my $phase (qw(unknown get make test install)) { # order matters
|
|
$methodmatch = 1 if $fforce || ($method && $phase eq $method);
|
|
next unless $methodmatch;
|
|
ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
|
|
if ($phase eq "get") {
|
|
if (substr($self->id,-1,1) eq "."
|
|
&& $att =~ /(unwrapped|build_dir|archived)/ ) {
|
|
# cannot be undone for local distros
|
|
next ATTRIBUTE;
|
|
}
|
|
if ($att eq "build_dir"
|
|
&& $self->{build_dir}
|
|
&& $CPAN::META->{is_tested}
|
|
) {
|
|
delete $CPAN::META->{is_tested}{$self->{build_dir}};
|
|
}
|
|
} elsif ($phase eq "test") {
|
|
if ($att eq "make_test"
|
|
&& $self->{make_test}
|
|
&& $self->{make_test}{COMMANDID}
|
|
&& $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
|
|
) {
|
|
# endless loop too likely
|
|
next ATTRIBUTE;
|
|
}
|
|
}
|
|
delete $self->{$att};
|
|
if ($ldebug || $CPAN::DEBUG) {
|
|
# local $CPAN::DEBUG = 16; # Distribution
|
|
CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
|
|
}
|
|
}
|
|
}
|
|
if ($method && $method =~ /make|test|install/) {
|
|
$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+\.\d+)
|
|
|
|
|
(5)[._-](00[0-5](?:_[0-4][0-9])?)
|
|
)
|
|
\.tar[._-](?:gz|bz2)
|
|
(?!\n)\Z
|
|
}xs) {
|
|
my $perl_version;
|
|
if ($2) {
|
|
$perl_version = $2;
|
|
} else {
|
|
$perl_version = "$3.$4";
|
|
}
|
|
return $perl_version;
|
|
} 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::shortcut_prepare ;
|
|
# return values: undef means don't shortcut; 0 means shortcut as fail;
|
|
# and 1 means shortcut as success
|
|
|
|
sub shortcut_prepare {
|
|
my ($self) = @_;
|
|
|
|
$self->debug("checking archive type[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (!$self->{archived} || $self->{archived} eq "NO") {
|
|
return $self->goodbye("Is neither a tar nor a zip archive.");
|
|
}
|
|
|
|
$self->debug("checking unwrapping[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (!$self->{unwrapped}
|
|
|| (
|
|
UNIVERSAL::can($self->{unwrapped},"failed") ?
|
|
$self->{unwrapped}->failed :
|
|
$self->{unwrapped} =~ /^NO/
|
|
)) {
|
|
return $self->goodbye("Had problems unarchiving. Please build manually");
|
|
}
|
|
|
|
$self->debug("checking signature[$self->{ID}]") if $CPAN::DEBUG;
|
|
if ( ! $self->{force_update}
|
|
&& exists $self->{signature_verify}
|
|
&& (
|
|
UNIVERSAL::can($self->{signature_verify},"failed") ?
|
|
$self->{signature_verify}->failed :
|
|
$self->{signature_verify} =~ /^NO/
|
|
)
|
|
) {
|
|
return $self->goodbye("Did not pass the signature test.");
|
|
}
|
|
|
|
$self->debug("checking writemakefile[$self->{ID}]") if $CPAN::DEBUG;
|
|
if ($self->{writemakefile}) {
|
|
if (
|
|
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 .= ", not re-running";
|
|
return $self->goodbye($err);
|
|
} else {
|
|
return $self->success("Has already been prepared");
|
|
}
|
|
}
|
|
|
|
$self->debug("checking configure_requires_later[$self->{ID}]") if $CPAN::DEBUG;
|
|
if( my $later = $self->{configure_requires_later} ) { # see also undelay
|
|
return $self->goodbye($later);
|
|
}
|
|
|
|
return undef; # no shortcut
|
|
}
|
|
|
|
sub prepare {
|
|
my ($self) = @_;
|
|
|
|
$self->get
|
|
or return;
|
|
|
|
if ( defined( my $sc = $self->shortcut_prepare) ) {
|
|
return $sc;
|
|
}
|
|
|
|
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
|
|
? $ENV{PERL5LIB}
|
|
: ($ENV{PERLLIB} || "");
|
|
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
|
|
local $ENV{PERL_USE_UNSAFE_INC} =
|
|
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
|
|
? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
|
|
$CPAN::META->set_perl5lib;
|
|
local $ENV{MAKEFLAGS}; # protect us from outer make calls
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
return;
|
|
}
|
|
|
|
my $builddir = $self->dir or
|
|
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
|
|
|
|
unless (chdir $builddir) {
|
|
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
|
|
return;
|
|
}
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
return;
|
|
}
|
|
|
|
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
|
|
|
|
local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL} || '';
|
|
local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL} || '';
|
|
$self->choose_MM_or_MB
|
|
or return;
|
|
|
|
my $configurator = $self->{configure} ? "Configure"
|
|
: $self->{modulebuild} ? "Build.PL"
|
|
: "Makefile.PL";
|
|
|
|
$CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");
|
|
|
|
if ($CPAN::Config->{prerequisites_policy} eq "follow") {
|
|
$ENV{PERL_AUTOINSTALL} ||= "--defaultdeps";
|
|
$ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
|
|
}
|
|
|
|
my $system;
|
|
my $pl_commandline;
|
|
if ($self->prefs->{pl}) {
|
|
$pl_commandline = $self->prefs->{pl}{commandline};
|
|
}
|
|
local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
|
|
local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING} || '';
|
|
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
|
|
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
|
|
if ($pl_commandline) {
|
|
$system = $pl_commandline;
|
|
$ENV{PERL} = $^X;
|
|
} elsif ($self->{'configure'}) {
|
|
$system = $self->{'configure'};
|
|
} elsif ($self->{modulebuild}) {
|
|
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
|
|
my $mbuildpl_arg = $self->_make_phase_arg("pl");
|
|
$system = sprintf("%s Build.PL%s",
|
|
$perl,
|
|
$mbuildpl_arg ? " $mbuildpl_arg" : "",
|
|
);
|
|
} else {
|
|
my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
|
|
my $switch = "";
|
|
# This needs a handler that can be turned on or off:
|
|
# $switch = "-MExtUtils::MakeMaker ".
|
|
# "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
|
|
# if $] > 5.00310;
|
|
my $makepl_arg = $self->_make_phase_arg("pl");
|
|
$ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
|
|
"Makefile.PL");
|
|
$system = sprintf("%s%s Makefile.PL%s",
|
|
$perl,
|
|
$switch ? " $switch" : "",
|
|
$makepl_arg ? " $makepl_arg" : "",
|
|
);
|
|
}
|
|
my $pl_env;
|
|
if ($self->prefs->{pl}) {
|
|
$pl_env = $self->prefs->{pl}{env};
|
|
}
|
|
local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
|
|
if (exists $self->{writemakefile}) {
|
|
} else {
|
|
local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
|
|
my($ret,$pid,$output);
|
|
$@ = "";
|
|
my $go_via_alarm;
|
|
if ($CPAN::Config->{inactivity_timeout}) {
|
|
require Config;
|
|
if ($Config::Config{d_alarm}
|
|
&&
|
|
$Config::Config{d_alarm} eq "define"
|
|
) {
|
|
$go_via_alarm++
|
|
} else {
|
|
$CPAN::Frontend->mywarn("Warning: you have configured the config ".
|
|
"variable 'inactivity_timeout' to ".
|
|
"'$CPAN::Config->{inactivity_timeout}'. But ".
|
|
"on this machine the system call 'alarm' ".
|
|
"isn't available. This means that we cannot ".
|
|
"provide the feature of intercepting long ".
|
|
"waiting code and will turn this feature off.\n"
|
|
);
|
|
$CPAN::Config->{inactivity_timeout} = 0;
|
|
}
|
|
}
|
|
if ($go_via_alarm) {
|
|
if ( $self->_should_report('pl') ) {
|
|
($output, $ret) = CPAN::Reporter::record_command(
|
|
$system,
|
|
$CPAN::Config->{inactivity_timeout},
|
|
);
|
|
CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
|
|
}
|
|
else {
|
|
eval {
|
|
alarm $CPAN::Config->{inactivity_timeout};
|
|
local $SIG{CHLD}; # = sub { wait };
|
|
if (defined($pid = fork)) {
|
|
if ($pid) { #parent
|
|
# wait;
|
|
waitpid $pid, 0;
|
|
} else { #child
|
|
# note, this exec isn't necessary if
|
|
# inactivity_timeout is 0. On the Mac I'd
|
|
# suggest, we set it always to 0.
|
|
exec $system;
|
|
}
|
|
} else {
|
|
$CPAN::Frontend->myprint("Cannot fork: $!");
|
|
return;
|
|
}
|
|
};
|
|
alarm 0;
|
|
if ($@) {
|
|
kill 9, $pid;
|
|
waitpid $pid, 0;
|
|
my $err = "$@";
|
|
$CPAN::Frontend->myprint($err);
|
|
$self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
|
|
$@ = "";
|
|
$self->store_persistent_state;
|
|
return $self->goodbye("$system -- TIMED OUT");
|
|
}
|
|
}
|
|
} else {
|
|
if (my $expect_model = $self->_prefs_with_expect("pl")) {
|
|
# XXX probably want to check _should_report here and warn
|
|
# about not being able to use CPAN::Reporter with expect
|
|
$ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
|
|
if (! defined $ret
|
|
&& $self->{writemakefile}
|
|
&& $self->{writemakefile}->failed) {
|
|
# timeout
|
|
return;
|
|
}
|
|
}
|
|
elsif ( $self->_should_report('pl') ) {
|
|
($output, $ret) = eval { CPAN::Reporter::record_command($system) };
|
|
if (! defined $output or $@) {
|
|
my $err = $@ || "Unknown error";
|
|
$CPAN::Frontend->mywarn("Error while running PL phase: $err\n");
|
|
$self->{writemakefile} = CPAN::Distrostatus
|
|
->new("NO '$system' returned status $ret and no output");
|
|
return $self->goodbye("$system -- NOT OK");
|
|
}
|
|
CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
|
|
}
|
|
else {
|
|
$ret = system($system);
|
|
}
|
|
if ($ret != 0) {
|
|
$self->{writemakefile} = CPAN::Distrostatus
|
|
->new("NO '$system' returned status $ret");
|
|
$CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
|
|
$self->store_persistent_state;
|
|
return $self->goodbye("$system -- NOT OK");
|
|
}
|
|
}
|
|
if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
|
|
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
|
|
delete $self->{make_clean}; # if cleaned before, enable next
|
|
$self->store_persistent_state;
|
|
return $self->success("$system -- OK");
|
|
} else {
|
|
my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
|
|
my $why = "No '$makefile' created";
|
|
$CPAN::Frontend->mywarn($why);
|
|
$self->{writemakefile} = CPAN::Distrostatus
|
|
->new(qq{NO -- $why\n});
|
|
$self->store_persistent_state;
|
|
return $self->goodbye("$system -- NOT OK");
|
|
}
|
|
}
|
|
$self->store_persistent_state;
|
|
return 1; # success
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::shortcut_make ;
|
|
# return values: undef means don't shortcut; 0 means shortcut as fail;
|
|
# and 1 means shortcut as success
|
|
sub shortcut_make {
|
|
my ($self) = @_;
|
|
|
|
$self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (defined $self->{make}) {
|
|
if (UNIVERSAL::can($self->{make},"failed") ?
|
|
$self->{make}->failed :
|
|
$self->{make} =~ /^NO/
|
|
) {
|
|
if ($self->{force_update}) {
|
|
# Trying an already failed 'make' (unless somebody else blocks)
|
|
return undef; # no shortcut
|
|
} else {
|
|
# introduced for turning recursion detection into a distrostatus
|
|
my $error = length $self->{make}>3
|
|
? substr($self->{make},3) : "Unknown error";
|
|
$self->store_persistent_state;
|
|
return $self->goodbye("Could not make: $error\n");
|
|
}
|
|
} else {
|
|
return $self->success("Has already been made")
|
|
}
|
|
}
|
|
return undef; # no shortcut
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::make ;
|
|
sub make {
|
|
my($self) = @_;
|
|
|
|
$self->pre_make();
|
|
|
|
if (exists $self->{cleanup_after_install_done}) {
|
|
$self->post_make();
|
|
return $self->get;
|
|
}
|
|
|
|
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (my $goto = $self->prefs->{goto}) {
|
|
$self->post_make();
|
|
return $self->goto($goto);
|
|
}
|
|
# Emergency brake if they said install Pippi and get newest perl
|
|
|
|
# XXX Would this make more sense in shortcut_prepare, since
|
|
# that doesn't make sense on a perl dist either? Broader
|
|
# question: what is the purpose of suggesting force install
|
|
# on a perl distribution? That seems unlikely to result in
|
|
# such a dependency being satisfied, even if the perl is
|
|
# successfully installed. This situation is tantamount to
|
|
# a prereq on a version of perl greater than the current one
|
|
# so I think we should just abort. -- xdg, 2012-04-06
|
|
if ($self->isa_perl) {
|
|
if (
|
|
$self->called_for ne $self->id &&
|
|
! $self->{force_update}
|
|
) {
|
|
# if we die here, we break bundles
|
|
$CPAN::Frontend
|
|
->mywarn(sprintf(
|
|
qq{The most recent version "%s" of the module "%s"
|
|
is part of the perl-%s distribution. To install that, you need to run
|
|
force install %s --or--
|
|
install %s
|
|
},
|
|
$CPAN::META->instance(
|
|
'CPAN::Module',
|
|
$self->called_for
|
|
)->cpan_version,
|
|
$self->called_for,
|
|
$self->isa_perl,
|
|
$self->called_for,
|
|
$self->pretty_id,
|
|
));
|
|
$self->{make} = CPAN::Distrostatus->new("NO isa perl");
|
|
$CPAN::Frontend->mysleep(1);
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
}
|
|
|
|
unless ($self->prepare){
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
if ( defined( my $sc = $self->shortcut_make) ) {
|
|
$self->post_make();
|
|
return $sc;
|
|
}
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
my $builddir = $self->dir or
|
|
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
|
|
|
|
unless (chdir $builddir) {
|
|
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
my $make = $self->{modulebuild} ? "Build" : "make";
|
|
$CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
|
|
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
|
|
? $ENV{PERL5LIB}
|
|
: ($ENV{PERLLIB} || "");
|
|
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
|
|
local $ENV{PERL_USE_UNSAFE_INC} =
|
|
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
|
|
? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
|
|
$CPAN::META->set_perl5lib;
|
|
local $ENV{MAKEFLAGS}; # protect us from outer make calls
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
if ($^O eq 'MacOS') {
|
|
Mac::BuildTools::make($self);
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
my %env;
|
|
while (my($k,$v) = each %ENV) {
|
|
next if defined $v;
|
|
$env{$k} = '';
|
|
}
|
|
local @ENV{keys %env} = values %env;
|
|
my $satisfied = eval { $self->satisfy_requires };
|
|
if ($@) {
|
|
return $self->goodbye($@);
|
|
}
|
|
unless ($satisfied){
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
# need to chdir again, because $self->satisfy_requires might change the directory
|
|
unless (chdir $builddir) {
|
|
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
|
|
$self->post_make();
|
|
return;
|
|
}
|
|
|
|
my $system;
|
|
my $make_commandline;
|
|
if ($self->prefs->{make}) {
|
|
$make_commandline = $self->prefs->{make}{commandline};
|
|
}
|
|
local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
|
|
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
|
|
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
|
|
if ($make_commandline) {
|
|
$system = $make_commandline;
|
|
$ENV{PERL} = CPAN::find_perl();
|
|
} else {
|
|
if ($self->{modulebuild}) {
|
|
unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
|
|
my $cwd = CPAN::anycwd();
|
|
$CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
|
|
" in cwd[$cwd]. Danger, Will Robinson!\n");
|
|
$CPAN::Frontend->mysleep(5);
|
|
}
|
|
$system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
|
|
} else {
|
|
$system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
|
|
}
|
|
$system =~ s/\s+$//;
|
|
my $make_arg = $self->_make_phase_arg("make");
|
|
$system = sprintf("%s%s",
|
|
$system,
|
|
$make_arg ? " $make_arg" : "",
|
|
);
|
|
}
|
|
my $make_env;
|
|
if ($self->prefs->{make}) {
|
|
$make_env = $self->prefs->{make}{env};
|
|
}
|
|
local @ENV{keys %$make_env} = values %$make_env if $make_env;
|
|
my $expect_model = $self->_prefs_with_expect("make");
|
|
my $want_expect = 0;
|
|
if ( $expect_model && @{$expect_model->{talk}} ) {
|
|
my $can_expect = $CPAN::META->has_inst("Expect");
|
|
if ($can_expect) {
|
|
$want_expect = 1;
|
|
} else {
|
|
$CPAN::Frontend->mywarn("Expect not installed, falling back to ".
|
|
"system()\n");
|
|
}
|
|
}
|
|
my ($system_ok, $system_err);
|
|
if ($want_expect) {
|
|
# XXX probably want to check _should_report here and
|
|
# warn about not being able to use CPAN::Reporter with expect
|
|
$system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
|
|
}
|
|
elsif ( $self->_should_report('make') ) {
|
|
my ($output, $ret) = CPAN::Reporter::record_command($system);
|
|
CPAN::Reporter::grade_make( $self, $system, $output, $ret );
|
|
$system_ok = ! $ret;
|
|
}
|
|
else {
|
|
my $rc = system($system);
|
|
$system_ok = $rc == 0;
|
|
$system_err = $! if $rc == -1;
|
|
}
|
|
$self->introduce_myself;
|
|
if ( $system_ok ) {
|
|
$CPAN::Frontend->myprint(" $system -- OK\n");
|
|
$self->{make} = CPAN::Distrostatus->new("YES");
|
|
} else {
|
|
$self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
|
|
$self->{make} = CPAN::Distrostatus->new("NO");
|
|
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
|
|
$CPAN::Frontend->mywarn(" $system_err\n") if defined $system_err;
|
|
}
|
|
$self->store_persistent_state;
|
|
|
|
$self->post_make();
|
|
|
|
return !! $system_ok;
|
|
}
|
|
|
|
# CPAN::Distribution::goodbye ;
|
|
sub goodbye {
|
|
my($self,$goodbye) = @_;
|
|
my $id = $self->pretty_id;
|
|
$CPAN::Frontend->mywarn(" $id\n $goodbye\n");
|
|
return 0; # must be explicit false, not undef
|
|
}
|
|
|
|
sub success {
|
|
my($self,$why) = @_;
|
|
my $id = $self->pretty_id;
|
|
$CPAN::Frontend->myprint(" $id\n $why\n");
|
|
return 1;
|
|
}
|
|
|
|
# CPAN::Distribution::_run_via_expect ;
|
|
sub _run_via_expect {
|
|
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 _make_install_make_command {
|
|
my ($self) = @_;
|
|
my $mimc =
|
|
CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
|
|
return $self->_make_command() unless $mimc;
|
|
|
|
# Quote the "make install" make command on Windows, where it is commonly
|
|
# found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
|
|
# do this in general because the command maybe "sudo make..." (i.e. a
|
|
# program with arguments), but that is unlikely to be the case on Windows.
|
|
$mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';
|
|
|
|
return $mimc;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::is_locally_optional
|
|
sub is_locally_optional {
|
|
my($self, $prereq_pm, $prereq) = @_;
|
|
$prereq_pm ||= $self->{prereq_pm};
|
|
my($nmo,$opt);
|
|
for my $rt (qw(requires build_requires)) {
|
|
if (exists $prereq_pm->{$rt}{$prereq}) {
|
|
# rt 121914
|
|
$nmo ||= $CPAN::META->instance("CPAN::Module",$prereq);
|
|
my $av = $nmo->available_version;
|
|
return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq});
|
|
}
|
|
if (exists $prereq_pm->{"opt_$rt"}{$prereq}) {
|
|
$opt = 1;
|
|
}
|
|
}
|
|
return $opt||0;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::follow_prereqs ;
|
|
sub follow_prereqs {
|
|
my($self) = shift;
|
|
my($slot) = shift;
|
|
my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
|
|
return unless @prereq_tuples;
|
|
my(@good_prereq_tuples);
|
|
for my $p (@prereq_tuples) {
|
|
# e.g. $p = ['Devel::PartialDump', 'r', 1]
|
|
# promote if possible
|
|
if ($p->[1] =~ /^(r|c)$/) {
|
|
push @good_prereq_tuples, $p;
|
|
} elsif ($p->[1] =~ /^(b)$/) {
|
|
my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
|
|
if ($reqtype =~ /^(r|c)$/) {
|
|
push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
|
|
} else {
|
|
push @good_prereq_tuples, $p;
|
|
}
|
|
} else {
|
|
die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
|
|
}
|
|
}
|
|
my $pretty_id = $self->pretty_id;
|
|
my %map = (
|
|
b => "build_requires",
|
|
r => "requires",
|
|
c => "commandline",
|
|
);
|
|
my($filler1,$filler2,$filler3,$filler4);
|
|
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 {sprintf " %s \[%s%s]\n", $_->[0], $map{$_->[1]}, $self->is_locally_optional(undef,$_->[0]) ? ",optional" : ""} @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;
|
|
my(@to_queue_mand,@to_queue_opt);
|
|
for my $gp (@good_prereq_tuples) {
|
|
my($prereq,$reqtype,$optional) = @$gp;
|
|
my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
|
|
if ($optional &&
|
|
$self->is_locally_optional(undef,$prereq)
|
|
){
|
|
# Since we do not depend on this one, we do not need
|
|
# this in a mandatory arrangement:
|
|
push @to_queue_opt, $qthing;
|
|
} else {
|
|
my $any = CPAN::Shell->expandany($prereq);
|
|
$self->{$slot . "_for"}{$any->id}++;
|
|
if ($any) {
|
|
unless ($optional) {
|
|
# No recursion check in an optional area of the tree
|
|
$any->color_cmd_tmps(0,2);
|
|
}
|
|
} else {
|
|
$CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
|
|
$CPAN::Frontend->mysleep(2);
|
|
}
|
|
# order everything that is not locally_optional just
|
|
# like mandatory items: this keeps leaves before
|
|
# branches
|
|
unshift @to_queue_mand, $qthing;
|
|
}
|
|
}
|
|
if (@to_queue_mand) {
|
|
unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
|
|
CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
|
|
$self->{$slot} = "Delayed until after prerequisites";
|
|
return 1; # signal we need dependencies
|
|
} elsif (@to_queue_opt) {
|
|
CPAN::Queue->jumpqueue(@to_queue_opt);
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
sub _feature_depends {
|
|
my($self) = @_;
|
|
my $meta_yml = $self->parse_meta_yml();
|
|
my $optf = $meta_yml->{optional_features} or return;
|
|
if (!ref $optf or ref $optf ne "HASH"){
|
|
$CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
|
|
$optf = {};
|
|
}
|
|
my $wantf = $self->prefs->{features} or return;
|
|
if (!ref $wantf or ref $wantf ne "ARRAY"){
|
|
$CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
|
|
$wantf = [];
|
|
}
|
|
my $dep = +{};
|
|
for my $wf (@$wantf) {
|
|
if (my $f = $optf->{$wf}) {
|
|
$CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
|
|
"is accompanied by this description:\n".
|
|
$f->{description}.
|
|
"\n\n"
|
|
);
|
|
# configure_requires currently not in the spec, unlikely to be useful anyway
|
|
for my $reqtype (qw(configure_requires build_requires requires)) {
|
|
my $reqhash = $f->{$reqtype} or next;
|
|
while (my($k,$v) = each %$reqhash) {
|
|
$dep->{$reqtype}{$k} = $v;
|
|
}
|
|
}
|
|
} else {
|
|
$CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
|
|
"found in the META.yml file".
|
|
"\n\n"
|
|
);
|
|
}
|
|
}
|
|
$dep;
|
|
}
|
|
|
|
sub prereqs_for_slot {
|
|
my($self,$slot) = @_;
|
|
my($prereq_pm);
|
|
unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
|
|
my $whynot = "not available";
|
|
if (defined $CPAN::Meta::Requirements::VERSION) {
|
|
$whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient";
|
|
}
|
|
$CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n");
|
|
my $before = "";
|
|
if ($self->{CALLED_FOR}){
|
|
if ($self->{CALLED_FOR} =~
|
|
/^(
|
|
CPAN::Meta::Requirements
|
|
|CPAN::DistnameInfo
|
|
|version
|
|
|parent
|
|
|ExtUtils::MakeMaker
|
|
|Test::Harness
|
|
)$/x) {
|
|
$CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ".
|
|
"as soon as possible; it is needed for a reliable operation of ".
|
|
"the cpan shell; setting requirements to nil for '$1' for now ".
|
|
"to prevent deadlock during bootstrapping\n");
|
|
return;
|
|
}
|
|
$before = " before $self->{CALLED_FOR}";
|
|
}
|
|
$CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before");
|
|
}
|
|
my $merged = CPAN::Meta::Requirements->new;
|
|
my $prefs_depends = $self->prefs->{depends}||{};
|
|
my $feature_depends = $self->_feature_depends();
|
|
if ($slot eq "configure_requires_later") {
|
|
for my $hash ( $self->configure_requires,
|
|
$prefs_depends->{configure_requires},
|
|
$feature_depends->{configure_requires},
|
|
) {
|
|
$merged->add_requirements(
|
|
CPAN::Meta::Requirements->from_string_hash($hash)
|
|
);
|
|
}
|
|
if (-f "Build.PL"
|
|
&& ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
|
|
&& ! $merged->requirements_for_module("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->add_minimum( "Module::Build" => 0 );
|
|
delete $self->{writemakefile};
|
|
}
|
|
$prereq_pm = {}; # configure_requires defined as "b"
|
|
} elsif ($slot eq "later") {
|
|
my $prereq_pm_0 = $self->prereq_pm || {};
|
|
for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
|
|
$prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
|
|
for my $dep ($prefs_depends,$feature_depends) {
|
|
for my $k (keys %{$dep->{$reqtype}||{}}) {
|
|
$prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
|
|
}
|
|
}
|
|
}
|
|
# XXX what about optional_req|breq? -- xdg, 2012-04-01
|
|
for my $hash (
|
|
$prereq_pm->{requires},
|
|
$prereq_pm->{build_requires},
|
|
$prereq_pm->{opt_requires},
|
|
$prereq_pm->{opt_build_requires},
|
|
|
|
) {
|
|
$merged->add_requirements(
|
|
CPAN::Meta::Requirements->from_string_hash($hash)
|
|
);
|
|
}
|
|
} else {
|
|
die "Panic: illegal slot '$slot'";
|
|
}
|
|
return ($merged->as_string_hash, $prereq_pm);
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::unsat_prereq ;
|
|
# return ([Foo,"r"],[Bar,"b"]) for normal modules
|
|
# return ([perl=>5.008]) if we need a newer perl than we are running under
|
|
# (sorry for the inconsistency, it was an accident)
|
|
sub unsat_prereq {
|
|
my($self,$slot) = @_;
|
|
my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
|
|
my(@need);
|
|
unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
|
|
$CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n");
|
|
return;
|
|
}
|
|
my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
|
|
my @merged = sort $merged->required_modules;
|
|
CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
|
|
NEED: for my $need_module ( @merged ) {
|
|
my $need_version = $merged->requirements_for_module($need_module);
|
|
my($available_version,$inst_file,$available_file,$nmo);
|
|
if ($need_module eq "perl") {
|
|
$available_version = $];
|
|
$available_file = CPAN::find_perl();
|
|
} else {
|
|
if (CPAN::_sqlite_running()) {
|
|
CPAN::Index->reload;
|
|
$CPAN::SQLite->search("CPAN::Module",$need_module);
|
|
}
|
|
$nmo = $CPAN::META->instance("CPAN::Module",$need_module);
|
|
$inst_file = $nmo->inst_file || '';
|
|
$available_file = $nmo->available_file || '';
|
|
$available_version = $nmo->available_version;
|
|
if ($nmo->uptodate) {
|
|
my $accepts = eval {
|
|
$merged->accepts_module($need_module, $available_version);
|
|
};
|
|
unless ($accepts) {
|
|
my $rq = $merged->requirements_for_module( $need_module );
|
|
$CPAN::Frontend->mywarn(
|
|
"Warning: Version '$available_version' of ".
|
|
"'$need_module' is up to date but does not ".
|
|
"fulfill requirements ($rq). I will continue, ".
|
|
"but chances to succeed are low.\n");
|
|
}
|
|
next NEED;
|
|
}
|
|
|
|
# if they have not specified a version, we accept any
|
|
# installed one; in that case inst_file is always
|
|
# sufficient and available_file is sufficient on
|
|
# both build_requires and configure_requires
|
|
my $sufficient = $inst_file ||
|
|
( exists $prereq_pm->{requires}{$need_module} ? 0 : $available_file );
|
|
if ( $sufficient
|
|
and ( # a few quick short circuits
|
|
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;
|
|
}
|
|
}
|
|
}
|
|
|
|
# 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 ) {
|
|
my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
|
|
(
|
|
$need_module,
|
|
$available_file,
|
|
$available_version,
|
|
$need_version,
|
|
);
|
|
if ( $inst_file
|
|
&& $available_file eq $inst_file
|
|
&& $nmo->inst_deprecated
|
|
) {
|
|
# continue installing as a prereq. we really want that
|
|
# because the deprecated module may spit out warnings
|
|
# and third party did not know until today. Only one
|
|
# exception is OK, because CPANPLUS is special after
|
|
# all:
|
|
if ( $fulfills_all_version_rqs and
|
|
$nmo->id =~ /^CPANPLUS(?:::Dist::Build)$/
|
|
) {
|
|
# here we have an available version that is good
|
|
# enough although deprecated (preventing circular
|
|
# loop CPANPLUS => CPANPLUS::Dist::Build RT#83042)
|
|
next NEED;
|
|
}
|
|
} elsif (
|
|
$self->{reqtype} # e.g. maybe we came via goto?
|
|
&& $self->{reqtype} =~ /^(r|c)$/
|
|
&& ( exists $prereq_pm->{requires}{$need_module}
|
|
|| exists $prereq_pm->{opt_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/) {
|
|
my $id = $need_distro->pretty_id;
|
|
$CPAN::Frontend->myprint("Promoting $id from build_requires to requires due $need_module\n");
|
|
delete $need_distro->{install}; # promote to another installation attempt
|
|
$need_distro->{reqtype} = "r";
|
|
$need_distro->install;
|
|
next NEED;
|
|
}
|
|
}
|
|
else {
|
|
next NEED if $fulfills_all_version_rqs;
|
|
}
|
|
}
|
|
|
|
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;
|
|
}
|
|
### XXX don't complain about missing optional deps -- xdg, 2012-04-01
|
|
if ($self->is_locally_optional($prereq_pm, $need_module)) {
|
|
# don't complain about failing optional prereqs
|
|
}
|
|
else {
|
|
$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}
|
|
|| exists $prereq_pm->{opt_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";
|
|
}
|
|
# here need to flag as optional for recommends/suggests
|
|
# -- xdg, 2012-04-01
|
|
$self->debug(sprintf "%s manadory?[%s]",
|
|
$self->pretty_id,
|
|
$self->{mandatory})
|
|
if $CPAN::DEBUG;
|
|
my $optional = !$self->{mandatory}
|
|
|| $self->is_locally_optional($prereq_pm, $need_module);
|
|
push @need, [$need_module,$needed_as,$optional];
|
|
}
|
|
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('\.yml$');
|
|
$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;
|
|
}
|
|
# no Makefile/Build means configuration aborted, so don't look for prereqs
|
|
my $makefile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'descrip.mms' : 'Makefile');
|
|
my $buildfile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'Build.com' : 'Build');
|
|
return unless -f $makefile || -f $buildfile;
|
|
CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
|
|
$self->{writemakefile}||"",
|
|
$self->{modulebuild}||"",
|
|
) if $CPAN::DEBUG;
|
|
my($req,$breq, $opt_req, $opt_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;
|
|
|
|
# XXX assemble optional_req && optional_breq from recommends/suggests
|
|
# depending on corresponding policies -- xdg, 2012-04-01
|
|
CPAN->use_inst("CPAN::Meta::Requirements");
|
|
my $opt_runtime = CPAN::Meta::Requirements->new;
|
|
my $opt_build = CPAN::Meta::Requirements->new;
|
|
if ( $CPAN::Config->{recommends_policy} ) {
|
|
$opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime recommends/));
|
|
$opt_build->add_requirements( $prereqs->requirements_for(qw/build recommends/));
|
|
$opt_build->add_requirements( $prereqs->requirements_for(qw/test recommends/));
|
|
|
|
}
|
|
if ( $CPAN::Config->{suggests_policy} ) {
|
|
$opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime suggests/));
|
|
$opt_build->add_requirements( $prereqs->requirements_for(qw/build suggests/));
|
|
$opt_build->add_requirements( $prereqs->requirements_for(qw/test suggests/));
|
|
}
|
|
$opt_req = $opt_runtime->as_string_hash;
|
|
$opt_breq = $opt_build->as_string_hash;
|
|
}
|
|
elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
|
|
$req = $yaml->{requires} || {};
|
|
$breq = $yaml->{build_requires} || {};
|
|
if ( $CPAN::Config->{recommends_policy} ) {
|
|
$opt_req = $yaml->{recommends} || {};
|
|
}
|
|
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;
|
|
foreach my $k (sort keys %{$req||{}}) {
|
|
my $v = $req->{$k};
|
|
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} || +{};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
# XXX needs to be adapted for optional_req & optional_breq -- xdg, 2012-04-01
|
|
if ($req || $breq || $opt_req || $opt_breq ) {
|
|
return $self->{prereq_pm} = {
|
|
requires => $req,
|
|
build_requires => $breq,
|
|
opt_requires => $opt_req,
|
|
opt_build_requires => $opt_breq,
|
|
};
|
|
}
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::shortcut_test ;
|
|
# return values: undef means don't shortcut; 0 means shortcut as fail;
|
|
# and 1 means shortcut as success
|
|
sub shortcut_test {
|
|
my ($self) = @_;
|
|
|
|
$self->debug("checking badtestcnt[$self->{ID}]") if $CPAN::DEBUG;
|
|
$self->{badtestcnt} ||= 0;
|
|
if ($self->{badtestcnt} > 0) {
|
|
require Data::Dumper;
|
|
CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
|
|
return $self->goodbye("Won't repeat unsuccessful test during this command");
|
|
}
|
|
|
|
for my $slot ( qw/later configure_requires_later/ ) {
|
|
$self->debug("checking $slot slot[$self->{ID}]") if $CPAN::DEBUG;
|
|
return $self->success($self->{$slot})
|
|
if $self->{$slot};
|
|
}
|
|
|
|
$self->debug("checking if tests passed[$self->{ID}]") if $CPAN::DEBUG;
|
|
if ( $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
|
|
) {
|
|
return $self->goodbye("Has already been tested within this command");
|
|
}
|
|
} else {
|
|
# 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});
|
|
}
|
|
return $self->success("Has already been tested successfully");
|
|
}
|
|
}
|
|
|
|
if ($self->{notest}) {
|
|
$self->{make_test} = CPAN::Distrostatus->new("YES");
|
|
return $self->success("Skipping test because of notest pragma");
|
|
}
|
|
|
|
return undef; # no shortcut
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::_exe_files ;
|
|
sub _exe_files {
|
|
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 $build_dir;
|
|
unless ( $build_dir = $self->{build_dir} ) {
|
|
return;
|
|
}
|
|
my $makefile = File::Spec->catfile($build_dir,"Makefile");
|
|
my $fh;
|
|
my @exe_files;
|
|
if (-f $makefile
|
|
and
|
|
$fh = FileHandle->new("<$makefile\0")) {
|
|
CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
|
|
local($/) = "\n";
|
|
while (<$fh>) {
|
|
last if /MakeMaker post_initialize section/;
|
|
my($p) = m{^[\#]
|
|
\s+EXE_FILES\s+=>\s+\[(.+)\]
|
|
}x;
|
|
next unless $p;
|
|
# warn "Found exefiles expr[$p]";
|
|
my @p = split /,\s*/, $p;
|
|
for my $p2 (@p) {
|
|
if ($p2 =~ /^q\[(.+)\]/) {
|
|
push @exe_files, $1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return \@exe_files if @exe_files;
|
|
my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
|
|
if (-f $buildparams) {
|
|
CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
|
|
my $x = do $buildparams;
|
|
for my $sf ($x->[2]{script_files}) {
|
|
if (my $reftype = ref $sf) {
|
|
if ($reftype eq "ARRAY") {
|
|
push @exe_files, @$sf;
|
|
}
|
|
elsif ($reftype eq "HASH") {
|
|
push @exe_files, keys %$sf;
|
|
}
|
|
else {
|
|
$CPAN::Frontend->mywarn("Invalid reftype $reftype for Build.PL 'script_files'\n");
|
|
}
|
|
}
|
|
elsif (defined $sf) {
|
|
push @exe_files, $sf;
|
|
}
|
|
}
|
|
}
|
|
return \@exe_files;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::test ;
|
|
sub test {
|
|
my($self) = @_;
|
|
|
|
$self->pre_test();
|
|
|
|
if (exists $self->{cleanup_after_install_done}) {
|
|
$self->post_test();
|
|
return $self->make;
|
|
}
|
|
|
|
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (my $goto = $self->prefs->{goto}) {
|
|
$self->post_test();
|
|
return $self->goto($goto);
|
|
}
|
|
|
|
unless ($self->make){
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
|
|
if ( defined( my $sc = $self->shortcut_test ) ) {
|
|
$self->post_test();
|
|
return $sc;
|
|
}
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
# warn "XDEBUG: checking for notest: $self->{notest} $self";
|
|
my $make = $self->{modulebuild} ? "Build" : "make";
|
|
|
|
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
|
|
? $ENV{PERL5LIB}
|
|
: ($ENV{PERLLIB} || "");
|
|
|
|
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
|
|
local $ENV{PERL_USE_UNSAFE_INC} =
|
|
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
|
|
? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
|
|
$CPAN::META->set_perl5lib;
|
|
local $ENV{MAKEFLAGS}; # protect us from outer make calls
|
|
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
|
|
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
|
|
|
|
if ($run_allow_installing_within_test) {
|
|
my($allow_installing, $why) = $self->_allow_installing;
|
|
if (! $allow_installing) {
|
|
$CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n");
|
|
$self->introduce_myself;
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why");
|
|
$CPAN::Frontend->mywarn(" [testing] -- NOT OK\n");
|
|
delete $self->{force_update};
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
}
|
|
$CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id);
|
|
|
|
my $builddir = $self->dir or
|
|
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
|
|
|
|
unless (chdir $builddir) {
|
|
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
|
|
$self->debug("Changed directory to $self->{build_dir}")
|
|
if $CPAN::DEBUG;
|
|
|
|
if ($^O eq 'MacOS') {
|
|
Mac::BuildTools::make_test($self);
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
|
|
if ($self->{modulebuild}) {
|
|
my $thm = CPAN::Shell->expand("Module","Test::Harness");
|
|
my $v = $thm->inst_version;
|
|
if (CPAN::Version->vlt($v,2.62)) {
|
|
# XXX Eric Wilhelm reported this as a bug: klapperl:
|
|
# Test::Harness 3.0 self-tests, so that should be 'unless
|
|
# installing Test::Harness'
|
|
unless ($self->id eq $thm->distribution->id) {
|
|
$CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
|
|
'$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( ! $self->{force_update} ) {
|
|
# bypass actual tests if "trust_test_report_history" and have a report
|
|
my $have_tested_fcn;
|
|
if ( $CPAN::Config->{trust_test_report_history}
|
|
&& $CPAN::META->has_inst("CPAN::Reporter::History")
|
|
&& ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
|
|
if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
|
|
# Do nothing if grade was DISCARD
|
|
if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
|
|
$self->{make_test} = CPAN::Distrostatus->new("YES");
|
|
# if global "is_tested" has been cleared, we need to mark this to
|
|
# be added to PERL5LIB if not already installed
|
|
if ($self->tested_ok_but_not_installed) {
|
|
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
|
|
}
|
|
$CPAN::Frontend->myprint("Found prior test report -- OK\n");
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO");
|
|
$self->{badtestcnt}++;
|
|
$CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
|
|
$self->post_test();
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my $system;
|
|
my $prefs_test = $self->prefs->{test};
|
|
if (my $commandline
|
|
= exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
|
|
$system = $commandline;
|
|
$ENV{PERL} = CPAN::find_perl();
|
|
} elsif ($self->{modulebuild}) {
|
|
$system = sprintf "%s test", $self->_build_command();
|
|
unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
|
|
my $id = $self->pretty_id;
|
|
$CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
|
|
}
|
|
} else {
|
|
$system = join " ", $self->_make_command(), "test";
|
|
}
|
|
my $make_test_arg = $self->_make_phase_arg("test");
|
|
$system = sprintf("%s%s",
|
|
$system,
|
|
$make_test_arg ? " $make_test_arg" : "",
|
|
);
|
|
my($tests_ok);
|
|
my $test_env;
|
|
if ($self->prefs->{test}) {
|
|
$test_env = $self->prefs->{test}{env};
|
|
}
|
|
local @ENV{keys %$test_env} = values %$test_env if $test_env;
|
|
my $expect_model = $self->_prefs_with_expect("test");
|
|
my $want_expect = 0;
|
|
if ( $expect_model && @{$expect_model->{talk}} ) {
|
|
my $can_expect = $CPAN::META->has_inst("Expect");
|
|
if ($can_expect) {
|
|
$want_expect = 1;
|
|
} else {
|
|
$CPAN::Frontend->mywarn("Expect not installed, falling back to ".
|
|
"testing without\n");
|
|
}
|
|
}
|
|
|
|
FORK: {
|
|
my $pid = fork;
|
|
if (! defined $pid) { # contention
|
|
warn "Contention '$!', sleeping 2";
|
|
sleep 2;
|
|
redo FORK;
|
|
} elsif ($pid) { # parent
|
|
if ($^O eq "MSWin32") {
|
|
wait;
|
|
} else {
|
|
SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
|
|
if ($CPAN::Signal) {
|
|
kill 9, -$pid;
|
|
}
|
|
sleep 1;
|
|
}
|
|
}
|
|
$tests_ok = !$?;
|
|
} else { # child
|
|
POSIX::setsid() unless $^O eq "MSWin32";
|
|
my $c_ok;
|
|
$|=1;
|
|
if ($want_expect) {
|
|
if ($self->_should_report('test')) {
|
|
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
|
|
"not supported when distroprefs specify ".
|
|
"an interactive test\n");
|
|
}
|
|
$c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
|
|
} elsif ( $self->_should_report('test') ) {
|
|
$c_ok = CPAN::Reporter::test($self, $system);
|
|
} else {
|
|
$c_ok = system($system) == 0;
|
|
}
|
|
exit !$c_ok;
|
|
}
|
|
} # FORK
|
|
|
|
$self->introduce_myself;
|
|
my $but = $self->_make_test_illuminate_prereqs();
|
|
if ( $tests_ok ) {
|
|
if ($but) {
|
|
$CPAN::Frontend->mywarn("Tests succeeded but $but\n");
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO $but");
|
|
$self->store_persistent_state;
|
|
$self->post_test();
|
|
return $self->goodbye("[dependencies] -- NA");
|
|
}
|
|
$CPAN::Frontend->myprint(" $system -- OK\n");
|
|
$self->{make_test} = CPAN::Distrostatus->new("YES");
|
|
$CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
|
|
# probably impossible to need the next line because badtestcnt
|
|
# has a lifespan of one command
|
|
delete $self->{badtestcnt};
|
|
} else {
|
|
if ($but) {
|
|
$but .= "; additionally test harness failed";
|
|
$CPAN::Frontend->mywarn("$but\n");
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO $but");
|
|
} elsif ( $self->{force_update} ) {
|
|
$self->{make_test} = CPAN::Distrostatus->new(
|
|
"NO but failure ignored because 'force' in effect"
|
|
);
|
|
} elsif ($CPAN::Signal) {
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted");
|
|
} else {
|
|
$self->{make_test} = CPAN::Distrostatus->new("NO");
|
|
}
|
|
$self->{badtestcnt}++;
|
|
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
|
|
CPAN::Shell->optprint
|
|
("hint",
|
|
sprintf
|
|
("//hint// to see the cpan-testers results for installing this module, try:
|
|
reports %s\n",
|
|
$self->pretty_id));
|
|
}
|
|
$self->store_persistent_state;
|
|
|
|
$self->post_test();
|
|
|
|
return $self->{force_update} ? 1 : !! $tests_ok;
|
|
}
|
|
|
|
sub _make_test_illuminate_prereqs {
|
|
my($self) = @_;
|
|
my @prereq;
|
|
|
|
# local $CPAN::DEBUG = 16; # Distribution
|
|
for my $m (sort keys %{$self->{sponsored_mods}}) {
|
|
next unless $self->{sponsored_mods}{$m} > 0;
|
|
my $m_obj = CPAN::Shell->expand("Module",$m) or next;
|
|
# XXX we need available_version which reflects
|
|
# $ENV{PERL5LIB} so that already tested but not yet
|
|
# installed modules are counted.
|
|
my $available_version = $m_obj->available_version;
|
|
my $available_file = $m_obj->available_file;
|
|
if ($available_version &&
|
|
!CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
|
|
) {
|
|
CPAN->debug("m[$m] good enough available_version[$available_version]")
|
|
if $CPAN::DEBUG;
|
|
} elsif ($available_file
|
|
&& (
|
|
!$self->{prereq_pm}{$m}
|
|
||
|
|
$self->{prereq_pm}{$m} == 0
|
|
)
|
|
) {
|
|
# lex Class::Accessor::Chained::Fast which has no $VERSION
|
|
CPAN->debug("m[$m] have available_file[$available_file]")
|
|
if $CPAN::DEBUG;
|
|
} else {
|
|
push @prereq, $m
|
|
unless $self->is_locally_optional(undef, $m);
|
|
}
|
|
}
|
|
my $but;
|
|
if (@prereq) {
|
|
my $cnt = @prereq;
|
|
my $which = join ",", @prereq;
|
|
$but = $cnt == 1 ? "one dependency not OK ($which)" :
|
|
"$cnt dependencies missing ($which)";
|
|
}
|
|
$but;
|
|
}
|
|
|
|
sub _prefs_with_expect {
|
|
my($self,$where) = @_;
|
|
return unless my $prefs = $self->prefs;
|
|
return unless my $where_prefs = $prefs->{$where};
|
|
if ($where_prefs->{expect}) {
|
|
return {
|
|
mode => "deterministic",
|
|
timeout => 15,
|
|
talk => $where_prefs->{expect},
|
|
};
|
|
} elsif ($where_prefs->{"eexpect"}) {
|
|
return $where_prefs->{"eexpect"};
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::clean ;
|
|
sub clean {
|
|
my($self) = @_;
|
|
my $make = $self->{modulebuild} ? "Build" : "make";
|
|
$CPAN::Frontend->myprint(sprintf "Running %s clean for %s\n", $make, $self->pretty_id);
|
|
unless (exists $self->{archived}) {
|
|
$CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
|
|
"/untarred, nothing done\n");
|
|
return 1;
|
|
}
|
|
unless (exists $self->{build_dir}) {
|
|
$CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
|
|
return 1;
|
|
}
|
|
if (exists $self->{writemakefile}
|
|
and $self->{writemakefile}->failed
|
|
) {
|
|
$CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
|
|
return 1;
|
|
}
|
|
EXCUSE: {
|
|
my @e;
|
|
exists $self->{make_clean} and $self->{make_clean} eq "YES" and
|
|
push @e, "make clean already called once";
|
|
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
|
|
}
|
|
chdir "$self->{build_dir}" or
|
|
Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
|
|
$self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
|
|
|
|
if ($^O eq 'MacOS') {
|
|
Mac::BuildTools::make_clean($self);
|
|
return;
|
|
}
|
|
|
|
my $system;
|
|
if ($self->{modulebuild}) {
|
|
unless (-f "Build") {
|
|
my $cwd = CPAN::anycwd();
|
|
$CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
|
|
" in cwd[$cwd]. Danger, Will Robinson!");
|
|
$CPAN::Frontend->mysleep(5);
|
|
}
|
|
$system = sprintf "%s clean", $self->_build_command();
|
|
} else {
|
|
$system = join " ", $self->_make_command(), "clean";
|
|
}
|
|
my $system_ok = system($system) == 0;
|
|
$self->introduce_myself;
|
|
if ( $system_ok ) {
|
|
$CPAN::Frontend->myprint(" $system -- OK\n");
|
|
|
|
# $self->force;
|
|
|
|
# Jost Krieger pointed out that this "force" was wrong because
|
|
# it has the effect that the next "install" on this distribution
|
|
# will untar everything again. Instead we should bring the
|
|
# object's state back to where it is after untarring.
|
|
|
|
for my $k (qw(
|
|
force_update
|
|
install
|
|
writemakefile
|
|
make
|
|
make_test
|
|
)) {
|
|
delete $self->{$k};
|
|
}
|
|
$self->{make_clean} = CPAN::Distrostatus->new("YES");
|
|
|
|
} else {
|
|
# Hmmm, what to do if make clean failed?
|
|
|
|
$self->{make_clean} = CPAN::Distrostatus->new("NO");
|
|
$CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
|
|
|
|
# 2006-02-27: seems silly to me to force a make now
|
|
# $self->force("make"); # so that this directory won't be used again
|
|
|
|
}
|
|
$self->store_persistent_state;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::check_disabled ;
|
|
sub check_disabled {
|
|
my ($self) = @_;
|
|
$self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
|
|
if ($self->prefs->{disabled} && ! $self->{force_update}) {
|
|
return sprintf(
|
|
"Disabled via prefs file '%s' doc %d",
|
|
$self->{prefs_file},
|
|
$self->{prefs_file_doc},
|
|
);
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::goto ;
|
|
sub goto {
|
|
my($self,$goto) = @_;
|
|
$goto = $self->normalize($goto);
|
|
my $why = sprintf(
|
|
"Goto '$goto' via prefs file '%s' doc %d",
|
|
$self->{prefs_file},
|
|
$self->{prefs_file_doc},
|
|
);
|
|
$self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
|
|
# 2007-07-16 akoenig : Better than NA would be if we could inherit
|
|
# the status of the $goto distro but given the exceptional nature
|
|
# of 'goto' I feel reluctant to implement it
|
|
my $goodbye_message = "[goto] -- NA $why";
|
|
$self->goodbye($goodbye_message);
|
|
|
|
# inject into the queue
|
|
|
|
CPAN::Queue->delete($self->id);
|
|
CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});
|
|
|
|
# and run where we left off
|
|
|
|
my($method) = (caller(1))[3];
|
|
my $goto_do = CPAN->instance("CPAN::Distribution",$goto);
|
|
$goto_do->called_for($self->called_for) unless $goto_do->called_for;
|
|
$goto_do->{mandatory} ||= $self->{mandatory};
|
|
$goto_do->{reqtype} ||= $self->{reqtype};
|
|
$goto_do->{coming_from} = $self->pretty_id;
|
|
$goto_do->$method();
|
|
CPAN::Queue->delete_first($goto);
|
|
# XXX delete_first returns undef; is that what this should return
|
|
# up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::shortcut_install ;
|
|
# return values: undef means don't shortcut; 0 means shortcut as fail;
|
|
# and 1 means shortcut as success
|
|
sub shortcut_install {
|
|
my ($self) = @_;
|
|
|
|
$self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (exists $self->{install}) {
|
|
my $text = UNIVERSAL::can($self->{install},"text") ?
|
|
$self->{install}->text :
|
|
$self->{install};
|
|
if ($text =~ /^YES/) {
|
|
$CPAN::META->is_installed($self->{build_dir});
|
|
return $self->success("Already done");
|
|
} elsif ($text =~ /is only/) {
|
|
# e.g. 'is only build_requires': may be overruled later
|
|
return $self->goodbye($text);
|
|
} else {
|
|
# comment in Todo on 2006-02-11; maybe retry?
|
|
return $self->goodbye("Already tried without success");
|
|
}
|
|
}
|
|
|
|
for my $slot ( qw/later configure_requires_later/ ) {
|
|
return $self->success($self->{$slot})
|
|
if $self->{$slot};
|
|
}
|
|
|
|
return undef;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::is_being_sponsored ;
|
|
|
|
# returns true if we find a distro object in the queue that has
|
|
# sponsored this one
|
|
sub is_being_sponsored {
|
|
my($self) = @_;
|
|
my $iterator = CPAN::Queue->iterator;
|
|
QITEM: while (my $q = $iterator->()) {
|
|
my $s = $q->as_string;
|
|
my $obj = CPAN::Shell->expandany($s) or next QITEM;
|
|
my $type = ref $obj;
|
|
if ( $type eq 'CPAN::Distribution' ){
|
|
for my $module (sort keys %{$obj->{sponsored_mods} || {}}) {
|
|
return 1 if grep { $_ eq $module } $self->containsmods;
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::install ;
|
|
sub install {
|
|
my($self) = @_;
|
|
|
|
$self->pre_install();
|
|
|
|
if (exists $self->{cleanup_after_install_done}) {
|
|
return $self->test;
|
|
}
|
|
|
|
$self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
|
|
if (my $goto = $self->prefs->{goto}) {
|
|
$self->goto($goto);
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
|
|
unless ($self->test) {
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
|
|
if ( defined( my $sc = $self->shortcut_install ) ) {
|
|
$self->post_install();
|
|
return $sc;
|
|
}
|
|
|
|
if ($CPAN::Signal) {
|
|
delete $self->{force_update};
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
|
|
my $builddir = $self->dir or
|
|
$CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
|
|
|
|
unless (chdir $builddir) {
|
|
$CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
|
|
$self->debug("Changed directory to $self->{build_dir}")
|
|
if $CPAN::DEBUG;
|
|
|
|
my $make = $self->{modulebuild} ? "Build" : "make";
|
|
$CPAN::Frontend->myprint(sprintf "Running %s install for %s\n", $make, $self->pretty_id);
|
|
|
|
if ($^O eq 'MacOS') {
|
|
Mac::BuildTools::make_install($self);
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
|
|
my $system;
|
|
if (my $commandline = $self->prefs->{install}{commandline}) {
|
|
$system = $commandline;
|
|
$ENV{PERL} = CPAN::find_perl();
|
|
} elsif ($self->{modulebuild}) {
|
|
my($mbuild_install_build_command) =
|
|
exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
|
|
$CPAN::Config->{mbuild_install_build_command} ?
|
|
$CPAN::Config->{mbuild_install_build_command} :
|
|
$self->_build_command();
|
|
my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
|
|
$system = sprintf("%s %s %s",
|
|
$mbuild_install_build_command,
|
|
$install_directive,
|
|
$CPAN::Config->{mbuild_install_arg},
|
|
);
|
|
} else {
|
|
my($make_install_make_command) = $self->_make_install_make_command();
|
|
$system = sprintf("%s install %s",
|
|
$make_install_make_command,
|
|
$CPAN::Config->{make_install_arg},
|
|
);
|
|
}
|
|
|
|
my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
|
|
my $brip = CPAN::HandleConfig->prefs_lookup($self,
|
|
q{build_requires_install_policy});
|
|
$brip ||="ask/yes";
|
|
my $id = $self->id;
|
|
my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
|
|
my $want_install = "yes";
|
|
if ($reqtype eq "b") {
|
|
if ($brip eq "no") {
|
|
$want_install = "no";
|
|
} elsif ($brip =~ m|^ask/(.+)|) {
|
|
my $default = $1;
|
|
$default = "yes" unless $default =~ /^(y|n)/i;
|
|
$want_install =
|
|
CPAN::Shell::colorable_makemaker_prompt
|
|
("$id is just needed temporarily during building or testing. ".
|
|
"Do you want to install it permanently?",
|
|
$default);
|
|
}
|
|
}
|
|
unless ($want_install =~ /^y/i) {
|
|
my $is_only = "is only 'build_requires'";
|
|
$self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
|
|
delete $self->{force_update};
|
|
$self->goodbye("Not installing because $is_only");
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
|
|
? $ENV{PERL5LIB}
|
|
: ($ENV{PERLLIB} || "");
|
|
|
|
local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
|
|
local $ENV{PERL_USE_UNSAFE_INC} =
|
|
exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
|
|
? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
|
|
$CPAN::META->set_perl5lib;
|
|
local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
|
|
local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
|
|
|
|
my $install_env;
|
|
if ($self->prefs->{install}) {
|
|
$install_env = $self->prefs->{install}{env};
|
|
}
|
|
local @ENV{keys %$install_env} = values %$install_env if $install_env;
|
|
|
|
if (! $run_allow_installing_within_test) {
|
|
my($allow_installing, $why) = $self->_allow_installing;
|
|
if (! $allow_installing) {
|
|
$CPAN::Frontend->mywarn("Installation stopped: $why\n");
|
|
$self->introduce_myself;
|
|
$self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why");
|
|
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
|
|
delete $self->{force_update};
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
}
|
|
my($pipe) = FileHandle->new("$system $stderr |");
|
|
unless ($pipe) {
|
|
$CPAN::Frontend->mywarn("Can't execute $system: $!");
|
|
$self->introduce_myself;
|
|
$self->{install} = CPAN::Distrostatus->new("NO");
|
|
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
|
|
delete $self->{force_update};
|
|
$self->post_install();
|
|
return;
|
|
}
|
|
my($makeout) = "";
|
|
while (<$pipe>) {
|
|
print $_; # intentionally NOT use Frontend->myprint because it
|
|
# looks irritating when we markup in color what we
|
|
# just pass through from an external program
|
|
$makeout .= $_;
|
|
}
|
|
$pipe->close;
|
|
my $close_ok = $? == 0;
|
|
$self->introduce_myself;
|
|
if ( $close_ok ) {
|
|
$CPAN::Frontend->myprint(" $system -- OK\n");
|
|
$CPAN::META->is_installed($self->{build_dir});
|
|
$self->{install} = CPAN::Distrostatus->new("YES");
|
|
if ($CPAN::Config->{'cleanup_after_install'}
|
|
&& ! $self->is_dot_dist
|
|
&& ! $self->is_being_sponsored) {
|
|
my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
|
|
chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
|
|
File::Path::rmtree($self->{build_dir});
|
|
my $yml = "$self->{build_dir}.yml";
|
|
if (-e $yml) {
|
|
unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
|
|
}
|
|
$self->{cleanup_after_install_done}=1;
|
|
}
|
|
} else {
|
|
$self->{install} = CPAN::Distrostatus->new("NO");
|
|
$CPAN::Frontend->mywarn(" $system -- NOT OK\n");
|
|
my $mimc =
|
|
CPAN::HandleConfig->prefs_lookup($self,
|
|
q{make_install_make_command});
|
|
if (
|
|
$makeout =~ /permission/s
|
|
&& $> > 0
|
|
&& (
|
|
! $mimc
|
|
|| $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
|
|
q{make}))
|
|
)
|
|
) {
|
|
$CPAN::Frontend->myprint(
|
|
qq{----\n}.
|
|
qq{ You may have to su }.
|
|
qq{to root to install the package\n}.
|
|
qq{ (Or you may want to run something like\n}.
|
|
qq{ o conf make_install_make_command 'sudo make'\n}.
|
|
qq{ to raise your permissions.}
|
|
);
|
|
}
|
|
}
|
|
delete $self->{force_update};
|
|
unless ($CPAN::Config->{'cleanup_after_install'}) {
|
|
$self->store_persistent_state;
|
|
}
|
|
|
|
$self->post_install();
|
|
|
|
return !! $close_ok;
|
|
}
|
|
|
|
sub blib_pm_walk {
|
|
my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch");
|
|
return sub {
|
|
LOOP: {
|
|
if (@queue) {
|
|
my $file = shift @queue;
|
|
if (-d $file) {
|
|
my $dh;
|
|
opendir $dh, $file or next;
|
|
my @newfiles = map {
|
|
my @ret;
|
|
my $maybedir = File::Spec->catdir($file, $_);
|
|
if (-d $maybedir) {
|
|
unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) {
|
|
# prune the blib/arch/auto directory, no pm files there
|
|
@ret = $maybedir;
|
|
}
|
|
} elsif (/\.pm$/) {
|
|
my $mustbefile = File::Spec->catfile($file, $_);
|
|
if (-f $mustbefile) {
|
|
@ret = $mustbefile;
|
|
}
|
|
}
|
|
@ret;
|
|
} grep {
|
|
$_ ne "."
|
|
&& $_ ne ".."
|
|
} readdir $dh;
|
|
push @queue, @newfiles;
|
|
redo LOOP;
|
|
} else {
|
|
return $file;
|
|
}
|
|
} else {
|
|
return;
|
|
}
|
|
}
|
|
};
|
|
}
|
|
|
|
sub _allow_installing {
|
|
my($self) = @_;
|
|
my $id = my $pretty_id = $self->pretty_id;
|
|
if ($self->{CALLED_FOR}) {
|
|
$id .= " (called for $self->{CALLED_FOR})";
|
|
}
|
|
my $allow_down = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades});
|
|
$allow_down ||= "ask/yes";
|
|
my $allow_outdd = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists});
|
|
$allow_outdd ||= "ask/yes";
|
|
return 1 if
|
|
$allow_down eq "yes"
|
|
&& $allow_outdd eq "yes";
|
|
if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) {
|
|
return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods;
|
|
if ($allow_outdd ne "yes") {
|
|
$CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as we are not equipped with 'CPAN::DistnameInfo' this option does not take effect\n");
|
|
$allow_outdd = "yes";
|
|
}
|
|
}
|
|
return 1 if
|
|
$allow_down eq "yes"
|
|
&& $allow_outdd eq "yes";
|
|
my($dist_version, $dist_dist);
|
|
if ($allow_outdd ne "yes"){
|
|
my $dni = CPAN::DistnameInfo->new($pretty_id);
|
|
$dist_version = $dni->version;
|
|
$dist_dist = $dni->dist;
|
|
}
|
|
my $iterator = blib_pm_walk();
|
|
my(@down,@outdd);
|
|
while (my $file = $iterator->()) {
|
|
my $version = CPAN::Module->parse_version($file);
|
|
my($volume, $directories, $pmfile) = File::Spec->splitpath( $file );
|
|
my @dirs = File::Spec->splitdir( $directories );
|
|
my(@blib_plus1) = splice @dirs, 0, 2;
|
|
my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile);
|
|
unless ($allow_down eq "yes") {
|
|
if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) {
|
|
my $inst_version = CPAN::Module->parse_version($inst_file);
|
|
my $cmp = CPAN::Version->vcmp($version, $inst_version);
|
|
if ($cmp) {
|
|
if ($cmp < 0) {
|
|
push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version };
|
|
}
|
|
}
|
|
if (@down) {
|
|
my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')";
|
|
if (my($default) = $allow_down =~ m|^ask/(.+)|) {
|
|
$default = "yes" unless $default =~ /^(y|n)/i;
|
|
my $answer = CPAN::Shell::colorable_makemaker_prompt
|
|
("$why. Do you want to allow installing it?",
|
|
$default, "colorize_warn");
|
|
$allow_down = $answer =~ /^\s*y/i ? "yes" : "no";
|
|
}
|
|
if ($allow_down eq "no") {
|
|
return (0, $why);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
unless ($allow_outdd eq "yes") {
|
|
my @pmpath = (@dirs, $pmfile);
|
|
$pmpath[-1] =~ s/\.pm$//;
|
|
my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath);
|
|
if ($mo) {
|
|
my $cpan_version = $mo->cpan_version;
|
|
my $is_lower = CPAN::Version->vlt($version, $cpan_version);
|
|
my $other_dist;
|
|
if (my $mo_dist = $mo->distribution) {
|
|
$other_dist = $mo_dist->pretty_id;
|
|
my $dni = CPAN::DistnameInfo->new($other_dist);
|
|
if ($dni->dist eq $dist_dist){
|
|
if (CPAN::Version->vgt($dni->version, $dist_version)) {
|
|
push @outdd, {
|
|
pmpath => $pmpath,
|
|
cpan_path => $dni->pathname,
|
|
dist_version => $dni->version,
|
|
dist_dist => $dni->dist,
|
|
};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (@outdd && $allow_outdd ne "yes") {
|
|
my $why = "allow_installing_outdated_dists: $id contains module(s) that are indexed on the CPAN with a different distro: (e.g. '$outdd[0]{pmpath}' is indexed with '$outdd[0]{cpan_path}')";
|
|
if ($outdd[0]{dist_dist} eq $dist_dist) {
|
|
$why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')";
|
|
}
|
|
if (my($default) = $allow_outdd =~ m|^ask/(.+)|) {
|
|
$default = "yes" unless $default =~ /^(y|n)/i;
|
|
my $answer = CPAN::Shell::colorable_makemaker_prompt
|
|
("$why. Do you want to allow installing it?",
|
|
$default, "colorize_warn");
|
|
$allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no";
|
|
}
|
|
if ($allow_outdd eq "no") {
|
|
return (0, $why);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub _file_in_path { # similar to CPAN::Module::_file_in_path
|
|
my($self,$pmpath,$incpath) = @_;
|
|
my($dir,@packpath);
|
|
foreach $dir (@$incpath) {
|
|
my $pmfile = File::Spec->catfile($dir,$pmpath);
|
|
if (-f $pmfile) {
|
|
return $pmfile;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
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";
|
|
}
|
|
elsif ($^O eq 'VMS') {
|
|
return "$^X Build.com";
|
|
}
|
|
return "./Build";
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::_should_report
|
|
sub _should_report {
|
|
my($self, $phase) = @_;
|
|
die "_should_report() requires a 'phase' argument"
|
|
if ! defined $phase;
|
|
|
|
return unless $CPAN::META->has_usable("CPAN::Reporter");
|
|
|
|
# configured
|
|
my $test_report = CPAN::HandleConfig->prefs_lookup($self,
|
|
q{test_report});
|
|
return unless $test_report;
|
|
|
|
# don't repeat if we cached a result
|
|
return $self->{should_report}
|
|
if exists $self->{should_report};
|
|
|
|
# don't report if we generated a Makefile.PL
|
|
if ( $self->{had_no_makefile_pl} ) {
|
|
$CPAN::Frontend->mywarn(
|
|
"Will not send CPAN Testers report with generated Makefile.PL.\n"
|
|
);
|
|
return $self->{should_report} = 0;
|
|
}
|
|
|
|
# available
|
|
if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
|
|
$CPAN::Frontend->mywarnonce(
|
|
"CPAN::Reporter not installed. No reports will be sent.\n"
|
|
);
|
|
return $self->{should_report} = 0;
|
|
}
|
|
|
|
# capable
|
|
my $crv = CPAN::Reporter->VERSION;
|
|
if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
|
|
# don't cache $self->{should_report} -- need to check each phase
|
|
if ( $phase eq 'test' ) {
|
|
return 1;
|
|
}
|
|
else {
|
|
$CPAN::Frontend->mywarn(
|
|
"Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
|
|
"you only have version $crv\. Only 'test' phase reports will be sent.\n"
|
|
);
|
|
return;
|
|
}
|
|
}
|
|
|
|
# appropriate
|
|
if ($self->is_dot_dist) {
|
|
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
|
|
"for local directories\n");
|
|
return $self->{should_report} = 0;
|
|
}
|
|
if ($self->prefs->{patches}
|
|
&&
|
|
@{$self->prefs->{patches}}
|
|
&&
|
|
$self->{patched}
|
|
) {
|
|
$CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
|
|
"when the source has been patched\n");
|
|
return $self->{should_report} = 0;
|
|
}
|
|
|
|
# proceed and cache success
|
|
return $self->{should_report} = 1;
|
|
}
|
|
|
|
#-> sub CPAN::Distribution::reports
|
|
sub reports {
|
|
my($self) = @_;
|
|
my $pathname = $self->id;
|
|
$CPAN::Frontend->myprint("Distribution: $pathname\n");
|
|
|
|
unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
|
|
$CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
|
|
}
|
|
unless ($CPAN::META->has_usable("LWP")) {
|
|
$CPAN::Frontend->mydie("LWP not installed; cannot continue");
|
|
}
|
|
unless ($CPAN::META->has_usable("File::Temp")) {
|
|
$CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
|
|
}
|
|
|
|
my $format;
|
|
if ($CPAN::META->has_inst("YAML::XS") || $CPAN::META->has_inst("YAML::Syck")){
|
|
$format = 'yaml';
|
|
}
|
|
elsif (!$format && $CPAN::META->has_inst("JSON::PP") ) {
|
|
$format = 'json';
|
|
}
|
|
else {
|
|
$CPAN::Frontend->mydie("JSON::PP not installed, cannot continue");
|
|
}
|
|
|
|
my $d = CPAN::DistnameInfo->new($pathname);
|
|
|
|
my $dist = $d->dist; # "CPAN-DistnameInfo"
|
|
my $version = $d->version; # "0.02"
|
|
my $maturity = $d->maturity; # "released"
|
|
my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
|
|
my $cpanid = $d->cpanid; # "GBARR"
|
|
my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
|
|
|
|
my $url = sprintf "http://www.cpantesters.org/show/%s.%s", $dist, $format;
|
|
|
|
CPAN::LWP::UserAgent->config;
|
|
my $Ua;
|
|
eval { $Ua = CPAN::LWP::UserAgent->new; };
|
|
if ($@) {
|
|
$CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
|
|
}
|
|
$CPAN::Frontend->myprint("Fetching '$url'...");
|
|
my $resp = $Ua->get($url);
|
|
unless ($resp->is_success) {
|
|
$CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
|
|
}
|
|
$CPAN::Frontend->myprint("DONE\n\n");
|
|
my $unserialized;
|
|
if ( $format eq 'yaml' ) {
|
|
my $yaml = $resp->content;
|
|
# what a long way round!
|
|
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': $!");
|
|
$unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
|
|
unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
|
|
} else {
|
|
require JSON::PP;
|
|
$unserialized = JSON::PP->new->utf8->decode($resp->content);
|
|
}
|
|
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 = substr($url,0,-4) . 'html';
|
|
$CPAN::Frontend->myprint("See $url for details\n");
|
|
}
|
|
|
|
1;
|