diff options
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm')
-rwxr-xr-x | Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm | 3879 |
1 files changed, 3879 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm b/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm new file mode 100755 index 00000000000..22d3f0640b3 --- /dev/null +++ b/Master/tlpkg/tlperl.straw/lib/CPAN/Distribution.pm @@ -0,0 +1,3879 @@ +package CPAN::Distribution; +use strict; +use Cwd qw(chdir); +use CPAN::Distroprefs; +use CPAN::InfoObj; +@CPAN::Distribution::ISA = qw(CPAN::InfoObj); +use vars qw($VERSION); +$VERSION = "1.94"; + +# Accessors +sub cpan_comment { + my $self = shift; + my $ro = $self->ro or return; + $ro->{CPAN_COMMENT} +} + +#-> CPAN::Distribution::undelay +sub undelay { + my $self = shift; + for my $delayer ( + "configure_requires_later", + "configure_requires_later_for", + "later", + "later_for", + ) { + delete $self->{$delayer}; + } +} + +#-> CPAN::Distribution::is_dot_dist +sub is_dot_dist { + my($self) = @_; + return substr($self->id,-1,1) eq "."; +} + +# add the A/AN/ stuff +#-> CPAN::Distribution::normalize +sub normalize { + my($self,$s) = @_; + $s = $self->id unless defined $s; + if (substr($s,-1,1) eq ".") { + # using a global because we are sometimes called as static method + if (!$CPAN::META->{LOCK} + && !$CPAN::Have_warned->{"$s is unlocked"}++ + ) { + $CPAN::Frontend->mywarn("You are visiting the local directory + '$s' + without lock, take care that concurrent processes do not do likewise.\n"); + $CPAN::Frontend->mysleep(1); + } + if ($s eq ".") { + $s = "$CPAN::iCwd/."; + } elsif (File::Spec->file_name_is_absolute($s)) { + } elsif (File::Spec->can("rel2abs")) { + $s = File::Spec->rel2abs($s); + } else { + $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec"); + } + CPAN->debug("s[$s]") if $CPAN::DEBUG; + unless ($CPAN::META->exists("CPAN::Distribution", $s)) { + for ($CPAN::META->instance("CPAN::Distribution", $s)) { + $_->{build_dir} = $s; + $_->{archived} = "local_directory"; + $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory"); + } + } + } elsif ( + $s =~ tr|/|| == 1 + or + $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| + ) { + return $s if $s =~ m:^N/A|^Contact Author: ; + $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|; + CPAN->debug("s[$s]") if $CPAN::DEBUG; + } + $s; +} + +#-> sub CPAN::Distribution::author ; +sub author { + my($self) = @_; + my($authorid); + if (substr($self->id,-1,1) eq ".") { + $authorid = "LOCAL"; + } else { + ($authorid) = $self->pretty_id =~ /^([\w\-]+)/; + } + CPAN::Shell->expand("Author",$authorid); +} + +# tries to get the yaml from CPAN instead of the distro itself: +# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels +sub fast_yaml { + my($self) = @_; + my $meta = $self->pretty_id; + $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/; + my(@ls) = CPAN::Shell->globls($meta); + my $norm = $self->normalize($meta); + + my($local_file); + my($local_wanted) = + File::Spec->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split(/\//,$norm) + ); + $self->debug("Doing localize") if $CPAN::DEBUG; + unless ($local_file = + CPAN::FTP->localize("authors/id/$norm", + $local_wanted)) { + $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n"); + } + my $yaml = CPAN->_yaml_loadfile($local_file)->[0]; +} + +#-> sub CPAN::Distribution::cpan_userid +sub cpan_userid { + my $self = shift; + if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) { + return $1; + } + return $self->SUPER::cpan_userid; +} + +#-> sub CPAN::Distribution::pretty_id +sub pretty_id { + my $self = shift; + my $id = $self->id; + return $id unless $id =~ m|^./../|; + substr($id,5); +} + +#-> sub CPAN::Distribution::base_id +sub base_id { + my $self = shift; + my $id = $self->pretty_id(); + my $base_id = File::Basename::basename($id); + $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; + return $base_id; +} + +#-> sub CPAN::Distribution::tested_ok_but_not_installed +sub tested_ok_but_not_installed { + my $self = shift; + return ( + $self->{make_test} + && $self->{build_dir} + && (UNIVERSAL::can($self->{make_test},"failed") ? + ! $self->{make_test}->failed : + $self->{make_test} =~ /^YES/ + ) + && ( + !$self->{install} + || + $self->{install}->failed + ) + ); +} + + +# mark as dirty/clean for the sake of recursion detection. $color=1 +# means "in use", $color=0 means "not in use anymore". $color=2 means +# we have determined prereqs now and thus insist on passing this +# through (at least) once again. + +#-> sub CPAN::Distribution::color_cmd_tmps ; +sub color_cmd_tmps { + my($self) = shift; + my($depth) = shift || 0; + my($color) = shift || 0; + my($ancestors) = shift || []; + # a distribution needs to recurse into its prereq_pms + + return if exists $self->{incommandcolor} + && $color==1 + && $self->{incommandcolor}==$color; + if ($depth>=$CPAN::MAX_RECURSION) { + die(CPAN::Exception::RecursiveDependency->new($ancestors)); + } + # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; + my $prereq_pm = $self->prereq_pm; + if (defined $prereq_pm) { + PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}}, + keys %{$prereq_pm->{build_requires}||{}}) { + next PREREQ if $pre eq "perl"; + my $premo; + unless ($premo = CPAN::Shell->expand("Module",$pre)) { + $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n"); + $CPAN::Frontend->mysleep(2); + next PREREQ; + } + $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]); + } + } + if ($color==0) { + delete $self->{sponsored_mods}; + + # as we are at the end of a command, we'll give up this + # reminder of a broken test. Other commands may test this guy + # again. Maybe 'badtestcnt' should be renamed to + # 'make_test_failed_within_command'? + delete $self->{badtestcnt}; + } + $self->{incommandcolor} = $color; +} + +#-> sub CPAN::Distribution::as_string ; +sub as_string { + my $self = shift; + $self->containsmods; + $self->upload_date; + $self->SUPER::as_string(@_); +} + +#-> sub CPAN::Distribution::containsmods ; +sub containsmods { + my $self = shift; + return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS}; + my $dist_id = $self->{ID}; + for my $mod ($CPAN::META->all_objects("CPAN::Module")) { + my $mod_file = $mod->cpan_file or next; + my $mod_id = $mod->{ID} or next; + # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]"; + # sleep 1; + if ($CPAN::Signal) { + delete $self->{CONTAINSMODS}; + return; + } + $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id; + } + keys %{$self->{CONTAINSMODS}||={}}; +} + +#-> sub CPAN::Distribution::upload_date ; +sub upload_date { + my $self = shift; + return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE}; + my(@local_wanted) = split(/\//,$self->id); + my $filename = pop @local_wanted; + push @local_wanted, "CHECKSUMS"; + my $author = CPAN::Shell->expand("Author",$self->cpan_userid); + return unless $author; + my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date}); + return unless @dl; + my($dirent) = grep { $_->[2] eq $filename } @dl; + # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id; + return unless $dirent->[1]; + return $self->{UPLOAD_DATE} = $dirent->[1]; +} + +#-> sub CPAN::Distribution::uptodate ; +sub uptodate { + my($self) = @_; + my $c; + foreach $c ($self->containsmods) { + my $obj = CPAN::Shell->expandany($c); + unless ($obj->uptodate) { + my $id = $self->pretty_id; + $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG; + return 0; + } + } + return 1; +} + +#-> sub CPAN::Distribution::called_for ; +sub called_for { + my($self,$id) = @_; + $self->{CALLED_FOR} = $id if defined $id; + return $self->{CALLED_FOR}; +} + +#-> sub CPAN::Distribution::get ; +sub get { + my($self) = @_; + $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; + if (my $goto = $self->prefs->{goto}) { + $CPAN::Frontend->mywarn + (sprintf( + "delegating to '%s' as specified in prefs file '%s' doc %d\n", + $goto, + $self->{prefs_file}, + $self->{prefs_file_doc}, + )); + return $self->goto($goto); + } + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? $ENV{PERL5LIB} + : ($ENV{PERLLIB} || ""); + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; + $CPAN::META->set_perl5lib; + local $ENV{MAKEFLAGS}; # protect us from outer make calls + + EXCUSE: { + my @e; + my $goodbye_message; + $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; + if ($self->prefs->{disabled} && ! $self->{force_update}) { + my $why = sprintf( + "Disabled via prefs file '%s' doc %d", + $self->{prefs_file}, + $self->{prefs_file_doc}, + ); + push @e, $why; + $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); + $goodbye_message = "[disabled] -- NA $why"; + # note: not intended to be persistent but at least visible + # during this session + } else { + if (exists $self->{build_dir} && -d $self->{build_dir} + && ($self->{modulebuild}||$self->{writemakefile}) + ) { + # this deserves print, not warn: + $CPAN::Frontend->myprint(" Has already been unwrapped into directory ". + "$self->{build_dir}\n" + ); + return 1; + } + + # although we talk about 'force' we shall not test on + # force directly. New model of force tries to refrain from + # direct checking of force. + exists $self->{unwrapped} and ( + UNIVERSAL::can($self->{unwrapped},"failed") ? + $self->{unwrapped}->failed : + $self->{unwrapped} =~ /^NO/ + ) + and push @e, "Unwrapping had some problem, won't try again without force"; + } + if (@e) { + $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e); + if ($goodbye_message) { + $self->goodbye($goodbye_message); + } + return; + } + } + my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible + + my($local_file); + unless ($self->{build_dir} && -d $self->{build_dir}) { + $self->get_file_onto_local_disk; + return if $CPAN::Signal; + $self->check_integrity; + return if $CPAN::Signal; + (my $packagedir,$local_file) = $self->run_preps_on_packagedir; + if (exists $self->{writemakefile} && ref $self->{writemakefile} + && $self->{writemakefile}->can("failed") && + $self->{writemakefile}->failed) { + return; + } + $packagedir ||= $self->{build_dir}; + $self->{build_dir} = $packagedir; + } + + if ($CPAN::Signal) { + $self->safe_chdir($sub_wd); + return; + } + return $self->choose_MM_or_MB($local_file); +} + +#-> CPAN::Distribution::get_file_onto_local_disk +sub get_file_onto_local_disk { + my($self) = @_; + + return if $self->is_dot_dist; + my($local_file); + my($local_wanted) = + File::Spec->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split(/\//,$self->id) + ); + + $self->debug("Doing localize") if $CPAN::DEBUG; + unless ($local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", + $local_wanted)) { + my $note = ""; + if ($CPAN::Index::DATE_OF_02) { + $note = "Note: Current database in memory was generated ". + "on $CPAN::Index::DATE_OF_02\n"; + } + $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); + } + + $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG; + $self->{localfile} = $local_file; +} + + +#-> CPAN::Distribution::check_integrity +sub check_integrity { + my($self) = @_; + + return if $self->is_dot_dist; + if ($CPAN::META->has_inst("Digest::SHA")) { + $self->debug("Digest::SHA is installed, verifying"); + $self->verifyCHECKSUM; + } else { + $self->debug("Digest::SHA is NOT installed"); + } +} + +#-> CPAN::Distribution::run_preps_on_packagedir +sub run_preps_on_packagedir { + my($self) = @_; + return if $self->is_dot_dist; + + $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok + my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok + $self->safe_chdir($builddir); + $self->debug("Removing tmp-$$") if $CPAN::DEBUG; + File::Path::rmtree("tmp-$$"); + unless (mkdir "tmp-$$", 0755) { + $CPAN::Frontend->unrecoverable_error(<<EOF); +Couldn't mkdir '$builddir/tmp-$$': $! + +Cannot continue: Please find the reason why I cannot make the +directory +$builddir/tmp-$$ +and fix the problem, then retry. + +EOF + } + if ($CPAN::Signal) { + return; + } + $self->safe_chdir("tmp-$$"); + + # + # Unpack the goods + # + my $local_file = $self->{localfile}; + my $ct = eval{CPAN::Tarzip->new($local_file)}; + unless ($ct) { + $self->{unwrapped} = CPAN::Distrostatus->new("NO"); + delete $self->{build_dir}; + return; + } + if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) { + $self->{was_uncompressed}++ unless eval{$ct->gtest()}; + $self->untar_me($ct); + } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) { + $self->unzip_me($ct); + } else { + $self->{was_uncompressed}++ unless $ct->gtest(); + $local_file = $self->handle_singlefile($local_file); + } + + # we are still in the tmp directory! + # Let's check if the package has its own directory. + my $dh = DirHandle->new(File::Spec->curdir) + or Carp::croak("Couldn't opendir .: $!"); + my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC?? + if (grep { $_ eq "pax_global_header" } @readdir) { + $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header' +from the tarball '$local_file'. +This is almost certainly an error. Please upgrade your tar. +I'll ignore this file for now. +See also http://rt.cpan.org/Ticket/Display.html?id=38932\n"); + $CPAN::Frontend->mysleep(5); + @readdir = grep { $_ ne "pax_global_header" } @readdir; + } + $dh->close; + my ($packagedir); + # XXX here we want in each branch File::Temp to protect all build_dir directories + if (CPAN->has_usable("File::Temp")) { + my $tdir_base; + my $from_dir; + my @dirents; + if (@readdir == 1 && -d $readdir[0]) { + $tdir_base = $readdir[0]; + $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); + my $dh2; + unless ($dh2 = DirHandle->new($from_dir)) { + my($mode) = (stat $from_dir)[2]; + my $why = sprintf + ( + "Couldn't opendir '%s', mode '%o': %s", + $from_dir, + $mode, + $!, + ); + $CPAN::Frontend->mywarn("$why\n"); + $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why"); + return; + } + @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC?? + } else { + my $userid = $self->cpan_userid; + CPAN->debug("userid[$userid]"); + if (!$userid or $userid eq "N/A") { + $userid = "anon"; + } + $tdir_base = $userid; + $from_dir = File::Spec->curdir; + @dirents = @readdir; + } + $packagedir = File::Temp::tempdir( + "$tdir_base-XXXXXX", + DIR => $builddir, + CLEANUP => 0, + ); + chmod 0777 &~ umask, $packagedir; # may fail + my $f; + for $f (@dirents) { # is already without "." and ".." + my $from = File::Spec->catdir($from_dir,$f); + my $to = File::Spec->catdir($packagedir,$f); + unless (File::Copy::move($from,$to)) { + my $err = $!; + $from = File::Spec->rel2abs($from); + Carp::confess("Couldn't move $from to $to: $err"); + } + } + } else { # older code below, still better than nothing when there is no File::Temp + my($distdir); + if (@readdir == 1 && -d $readdir[0]) { + $distdir = $readdir[0]; + $packagedir = File::Spec->catdir($builddir,$distdir); + $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]") + if $CPAN::DEBUG; + -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ". + "$packagedir\n"); + File::Path::rmtree($packagedir); + unless (File::Copy::move($distdir,$packagedir)) { + $CPAN::Frontend->unrecoverable_error(<<EOF); +Couldn't move '$distdir' to '$packagedir': $! + +Cannot continue: Please find the reason why I cannot move +$builddir/tmp-$$/$distdir +to +$packagedir +and fix the problem, then retry + +EOF + } + $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]", + $distdir, + $packagedir, + -e $packagedir, + -d $packagedir, + )) if $CPAN::DEBUG; + } else { + my $userid = $self->cpan_userid; + CPAN->debug("userid[$userid]") if $CPAN::DEBUG; + if (!$userid or $userid eq "N/A") { + $userid = "anon"; + } + my $pragmatic_dir = $userid . '000'; + $pragmatic_dir =~ s/\W_//g; + $pragmatic_dir++ while -d "../$pragmatic_dir"; + $packagedir = File::Spec->catdir($builddir,$pragmatic_dir); + $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG; + File::Path::mkpath($packagedir); + my($f); + for $f (@readdir) { # is already without "." and ".." + my $to = File::Spec->catdir($packagedir,$f); + File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!"); + } + } + } + $self->{build_dir} = $packagedir; + $self->safe_chdir($builddir); + File::Path::rmtree("tmp-$$"); + + $self->safe_chdir($packagedir); + $self->_signature_business(); + $self->safe_chdir($builddir); + + return($packagedir,$local_file); +} + +#-> sub CPAN::Distribution::parse_meta_yml ; +sub parse_meta_yml { + my($self) = @_; + my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir"; + my $yaml = File::Spec->catfile($build_dir,"META.yml"); + $self->debug("yaml[$yaml]") if $CPAN::DEBUG; + return unless -f $yaml; + my $early_yaml; + eval { + require Parse::CPAN::Meta; + $early_yaml = Parse::CPAN::Meta::LoadFile($yaml)->[0]; + }; + unless ($early_yaml) { + eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; }; + } + unless ($early_yaml) { + return; + } + return $early_yaml; +} + +#-> sub CPAN::Distribution::satisfy_requires ; +sub satisfy_requires { + my ($self) = @_; + if (my @prereq = $self->unsat_prereq("later")) { + if ($prereq[0][0] eq "perl") { + my $need = "requires perl '$prereq[0][1]'"; + my $id = $self->pretty_id; + $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n"); + $self->{make} = CPAN::Distrostatus->new("NO $need"); + $self->store_persistent_state; + die "[prereq] -- NOT OK\n"; + } else { + my $follow = eval { $self->follow_prereqs("later",@prereq); }; + if (0) { + } elsif ($follow) { + # signal success to the queuerunner + return 1; + } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { + $CPAN::Frontend->mywarn($@); + die "[depend] -- NOT OK\n"; + } + } + } +} + +#-> sub CPAN::Distribution::satisfy_configure_requires ; +sub satisfy_configure_requires { + my($self) = @_; + 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") or return 1; + if ($self->{configure_requires_later}) { + for my $k (keys %{$self->{configure_requires_later_for}||{}}) { + if ($self->{configure_requires_later_for}{$k}>1) { + # we must not come here a second time + $CPAN::Frontend->mywarn("Panic: Some prerequisites is not available, please investigate..."); + require YAML::Syck; + $CPAN::Frontend->mydie + ( + YAML::Syck::Dump + ({self=>$self, prereq=>\@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; + return $self->goodbye("[prereq] -- NOT OK"); + } else { + my $follow = eval { + $self->follow_prereqs("configure_requires_later", @prereq); + }; + if (0) { + } elsif ($follow) { + return; + } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) { + $CPAN::Frontend->mywarn($@); + return $self->goodbye("[depend] -- NOT OK"); + } + else { + return $self->goodbye("[configure_requires] -- NOT OK"); + } + } + die "never reached"; +} + +#-> sub CPAN::Distribution::choose_MM_or_MB ; +sub choose_MM_or_MB { + my($self,$local_file) = @_; + $self->satisfy_configure_requires() or return; + my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL"); + my($mpl_exists) = -f $mpl; + unless ($mpl_exists) { + # NFS has been reported to have racing problems after the + # renaming of a directory in some environments. + # This trick helps. + $CPAN::Frontend->mysleep(1); + my $mpldh = DirHandle->new($self->{build_dir}) + or Carp::croak("Couldn't opendir $self->{build_dir}: $!"); + $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; + $mpldh->close; + } + my $prefer_installer = "eumm"; # eumm|mb + if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) { + if ($mpl_exists) { # they *can* choose + if ($CPAN::META->has_inst("Module::Build")) { + $prefer_installer = CPAN::HandleConfig->prefs_lookup( + $self, q{prefer_installer} + ); + # M::B <= 0.35 left a DATA handle open that + # causes problems upgrading M::B on Windows + close *Module::Build::Version::DATA + if fileno *Module::Build::Version::DATA; + } + } else { + $prefer_installer = "mb"; + } + } + return unless $self->patch; + if (lc($prefer_installer) eq "rand") { + $prefer_installer = rand()<.5 ? "eumm" : "mb"; + } + if (lc($prefer_installer) eq "mb") { + $self->{modulebuild} = 1; + } elsif ($self->{archived} eq "patch") { + # not an edge case, nothing to install for sure + my $why = "A patch file cannot be installed"; + $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n"); + $self->{writemakefile} = CPAN::Distrostatus->new("NO $why"); + } elsif (! $mpl_exists) { + $self->_edge_cases($mpl,$local_file); + } + if ($self->{build_dir} + && + $CPAN::Config->{build_dir_reuse} + ) { + $self->store_persistent_state; + } + return $self; +} + +#-> CPAN::Distribution::store_persistent_state +sub store_persistent_state { + my($self) = @_; + my $dir = $self->{build_dir}; + unless (File::Spec->canonpath(File::Basename::dirname($dir)) + eq File::Spec->canonpath($CPAN::Config->{build_dir})) { + $CPAN::Frontend->mywarn("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->myprint("Warning (usually harmless): '$yaml_module' not installed, ". + "will not store persistent state\n"); + } +} + +#-> CPAN::Distribution::try_download +sub try_download { + my($self,$patch) = @_; + my $norm = $self->normalize($patch); + my($local_wanted) = + File::Spec->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split(/\//,$norm), + ); + $self->debug("Doing localize") if $CPAN::DEBUG; + return CPAN::FTP->localize("authors/id/$norm", + $local_wanted); +} + +{ + my $stdpatchargs = ""; + #-> CPAN::Distribution::patch + sub patch { + my($self) = @_; + $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG; + my $patches = $self->prefs->{patches}; + $patches ||= ""; + $self->debug("patches[$patches]") if $CPAN::DEBUG; + if ($patches) { + return unless @$patches; + $self->safe_chdir($self->{build_dir}); + CPAN->debug("patches[$patches]") if $CPAN::DEBUG; + my $patchbin = $CPAN::Config->{patch}; + unless ($patchbin && length $patchbin) { + $CPAN::Frontend->mydie("No external patch command configured\n\n". + "Please run 'o conf init /patch/'\n\n"); + } + unless (MM->maybe_command($patchbin)) { + $CPAN::Frontend->mydie("No external patch command available\n\n". + "Please run 'o conf init /patch/'\n\n"); + } + $patchbin = CPAN::HandleConfig->safe_quote($patchbin); + local $ENV{PATCH_GET} = 0; # formerly known as -g0 + unless ($stdpatchargs) { + my $system = "$patchbin --version |"; + local *FH; + open FH, $system or die "Could not fork '$system': $!"; + local $/ = "\n"; + my $pversion; + PARSEVERSION: while (<FH>) { + if (/^patch\s+([\d\.]+)/) { + $pversion = $1; + last PARSEVERSION; + } + } + if ($pversion) { + $stdpatchargs = "-N --fuzz=3"; + } else { + $stdpatchargs = "-N"; + } + } + my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches"); + $CPAN::Frontend->myprint("Going to apply $countedpatches:\n"); + my $patches_dir = $CPAN::Config->{patches_dir}; + for my $patch (@$patches) { + if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) { + my $f = File::Spec->catfile($patches_dir, $patch); + $patch = $f if -f $f; + } + unless (-f $patch) { + CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG; + if (my $trydl = $self->try_download($patch)) { + $patch = $trydl; + } else { + my $fail = "Could not find patch '$patch'"; + $CPAN::Frontend->mywarn("$fail; cannot continue\n"); + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail"); + delete $self->{build_dir}; + return; + } + } + $CPAN::Frontend->myprint(" $patch\n"); + my $readfh = CPAN::Tarzip->TIEHANDLE($patch); + + my $pcommand; + my $ppp = $self->_patch_p_parameter($readfh); + if ($ppp eq "applypatch") { + $pcommand = "$CPAN::Config->{applypatch} -verbose"; + } else { + my $thispatchargs = join " ", $stdpatchargs, $ppp; + $pcommand = "$patchbin $thispatchargs"; + } + + $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; + } +} + +sub _patch_p_parameter { + my($self,$fh) = @_; + my $cnt_files = 0; + my $cnt_p0files = 0; + local($_); + while ($_ = $fh->READLINE) { + if ( + $CPAN::Config->{applypatch} + && + /\#\#\#\# ApplyPatch data follows \#\#\#\#/ + ) { + return "applypatch" + } + next unless /^[\*\+]{3}\s(\S+)/; + my $file = $1; + $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; + return $cnt_files==$cnt_p0files ? "-p0" : "-p1"; +} + +#-> sub CPAN::Distribution::_edge_cases +# with "configure" or "Makefile" or single file scripts +sub _edge_cases { + my($self,$mpl,$local_file) = @_; + $self->debug(sprintf("makefilepl[%s]anycwd[%s]", + $mpl, + CPAN::anycwd(), + )) if $CPAN::DEBUG; + my $build_dir = $self->{build_dir}; + my($configure) = File::Spec->catfile($build_dir,"Configure"); + if (-f $configure) { + # do we have anything to do? + $self->{configure} = $configure; + } elsif (-f File::Spec->catfile($build_dir,"Makefile")) { + $CPAN::Frontend->mywarn(qq{ +Package comes with a Makefile and without a Makefile.PL. +We\'ll try to build it with that Makefile then. +}); + $self->{writemakefile} = CPAN::Distrostatus->new("YES"); + $CPAN::Frontend->mysleep(2); + } else { + my $cf = $self->called_for || "unknown"; + if ($cf =~ m|/|) { + $cf =~ s|.*/||; + $cf =~ s|\W.*||; + } + $cf =~ s|[/\\:]||g; # risk of filesystem damage + $cf = "unknown" unless length($cf); + if (my $crud = $self->_contains_crud($build_dir)) { + my $why = qq{Package contains $crud; not recognized as a perl package, giving up}; + $CPAN::Frontend->mywarn("$why\n"); + $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why}); + return; + } + $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL. + (The test -f "$mpl" returned false.) + Writing one on our own (setting NAME to $cf)\a\n}); + $self->{had_no_makefile_pl}++; + $CPAN::Frontend->mysleep(3); + + # Writing our own Makefile.PL + + my $exefile_stanza = ""; + if ($self->{archived} eq "maybe_pl") { + $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file); + } + + my $fh = FileHandle->new; + $fh->open(">$mpl") + or Carp::croak("Could not open >$mpl: $!"); + $fh->print( + qq{# This Makefile.PL has been autogenerated by the module CPAN.pm +# because there was no Makefile.PL supplied. +# Autogenerated on: }.scalar localtime().qq{ + +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => q[$cf],$exefile_stanza + ); +}); + $fh->close; + } +} + +#-> CPAN;:Distribution::_contains_crud +sub _contains_crud { + my($self,$dir) = @_; + my(@dirs, $dh, @files); + opendir $dh, $dir or return; + my $dirent; + for $dirent (readdir $dh) { + next if $dirent =~ /^\.\.?$/; + my $path = File::Spec->catdir($dir,$dirent); + if (-d $path) { + push @dirs, $dirent; + } elsif (-f $path) { + push @files, $dirent; + } + } + if (@dirs && @files) { + return "both files[@files] and directories[@dirs]"; + } elsif (@files > 2) { + return "several files[@files] but no Makefile.PL or Build.PL"; + } + return; +} + +#-> CPAN;:Distribution::_exefile_stanza +sub _exefile_stanza { + my($self,$build_dir,$local_file) = @_; + + my $fh = FileHandle->new; + my $script_file = File::Spec->catfile($build_dir,$local_file); + $fh->open($script_file) + or Carp::croak("Could not open script '$script_file': $!"); + local $/ = "\n"; + # name parsen und prereq + my($state) = "poddir"; + my($name, $prereq) = ("", ""); + while (<$fh>) { + if ($state eq "poddir" && /^=head\d\s+(\S+)/) { + if ($1 eq 'NAME') { + $state = "name"; + } elsif ($1 eq 'PREREQUISITES') { + $state = "prereq"; + } + } elsif ($state =~ m{^(name|prereq)$}) { + if (/^=/) { + $state = "poddir"; + } elsif (/^\s*$/) { + # nop + } elsif ($state eq "name") { + if ($name eq "") { + ($name) = /^(\S+)/; + $state = "poddir"; + } + } elsif ($state eq "prereq") { + $prereq .= $_; + } + } elsif (/^=cut\b/) { + last; + } + } + $fh->close; + + for ($name) { + s{.*<}{}; # strip X<...> + s{>.*}{}; + } + chomp $prereq; + $prereq = join " ", split /\s+/, $prereq; + my($PREREQ_PM) = join("\n", map { + s{.*<}{}; # strip X<...> + s{>.*}{}; + if (/[\s\'\"]/) { # prose? + } else { + s/[^\w:]$//; # period? + " "x28 . "'$_' => 0,"; + } + } split /\s*,\s*/, $prereq); + + if ($name) { + my $to_file = File::Spec->catfile($build_dir, $name); + rename $script_file, $to_file + or die "Can't rename $script_file to $to_file: $!"; + } + + return " + EXE_FILES => ['$name'], + PREREQ_PM => { +$PREREQ_PM + }, +"; +} + +#-> CPAN::Distribution::_signature_business +sub _signature_business { + my($self) = @_; + my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, + q{check_sigs}); + if ($check_sigs) { + if ($CPAN::META->has_inst("Module::Signature")) { + if (-f "SIGNATURE") { + $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; + my $rv = Module::Signature::verify(); + if ($rv != Module::Signature::SIGNATURE_OK() and + $rv != Module::Signature::SIGNATURE_MISSING()) { + $CPAN::Frontend->mywarn( + qq{\nSignature invalid for }. + qq{distribution file. }. + qq{Please investigate.\n\n} + ); + + my $wrap = + sprintf(qq{I'd recommend removing %s. Some error occurred }. + qq{while checking its signature, so it could }. + qq{be invalid. Maybe you have configured }. + qq{your 'urllist' with a bad URL. Please check this }. + qq{array with 'o conf urllist' and retry. Or }. + qq{examine the distribution in a subshell. Try + look %s +and run + cpansign -v +}, + $self->{localfile}, + $self->pretty_id, + ); + $self->{signature_verify} = CPAN::Distrostatus->new("NO"); + $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap)); + $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep"); + } else { + $self->{signature_verify} = CPAN::Distrostatus->new("YES"); + $self->debug("Module::Signature has verified") if $CPAN::DEBUG; + } + } else { + $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n}); + } + } else { + $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; + } + } +} + +#-> CPAN::Distribution::untar_me ; +sub untar_me { + my($self,$ct) = @_; + $self->{archived} = "tar"; + my $result = eval { $ct->untar() }; + if ($result) { + $self->{unwrapped} = CPAN::Distrostatus->new("YES"); + } else { + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed"); + } +} + +# CPAN::Distribution::unzip_me ; +sub unzip_me { + my($self,$ct) = @_; + $self->{archived} = "zip"; + if ($ct->unzip()) { + $self->{unwrapped} = CPAN::Distrostatus->new("YES"); + } else { + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); + } + return; +} + +sub handle_singlefile { + my($self,$local_file) = @_; + + if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) { + $self->{archived} = "pm"; + } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) { + $self->{archived} = "patch"; + } else { + $self->{archived} = "maybe_pl"; + } + + my $to = File::Basename::basename($local_file); + if ($to =~ s/\.(gz|Z)(?!\n)\Z//) { + if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) { + $self->{unwrapped} = CPAN::Distrostatus->new("YES"); + } else { + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed"); + } + } else { + if (File::Copy::cp($local_file,".")) { + $self->{unwrapped} = CPAN::Distrostatus->new("YES"); + } else { + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed"); + } + } + return $to; +} + +#-> sub CPAN::Distribution::new ; +sub new { + my($class,%att) = @_; + + # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); + + my $this = { %att }; + return bless $this, $class; +} + +#-> sub CPAN::Distribution::look ; +sub look { + my($self) = @_; + + if ($^O eq 'MacOS') { + $self->Mac::BuildTools::look; + return; + } + + if ( $CPAN::Config->{'shell'} ) { + $CPAN::Frontend->myprint(qq{ +Trying to open a subshell in the build directory... +}); + } else { + $CPAN::Frontend->myprint(qq{ +Your configuration does not define a value for subshells. +Please define it with "o conf shell <your shell>" +}); + return; + } + my $dist = $self->id; + my $dir; + unless ($dir = $self->dir) { + $self->get; + } + unless ($dir ||= $self->dir) { + $CPAN::Frontend->mywarn(qq{ +Could not determine which directory to use for looking at $dist. +}); + return; + } + my $pwd = CPAN::anycwd(); + $self->safe_chdir($dir); + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + { + local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0; + $ENV{CPAN_SHELL_LEVEL} += 1; + my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'}); + + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? $ENV{PERL5LIB} + : ($ENV{PERLLIB} || ""); + + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; + $CPAN::META->set_perl5lib; + local $ENV{MAKEFLAGS}; # protect us from outer make calls + + unless (system($shell) == 0) { + my $code = $? >> 8; + $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n"); + } + } + $self->safe_chdir($pwd); +} + +# CPAN::Distribution::cvs_import ; +sub cvs_import { + my($self) = @_; + $self->get; + my $dir = $self->dir; + + my $package = $self->called_for; + my $module = $CPAN::META->instance('CPAN::Module', $package); + my $version = $module->cpan_version; + + my $userid = $self->cpan_userid; + + my $cvs_dir = (split /\//, $dir)[-1]; + $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//; + my $cvs_root = + $CPAN::Config->{cvsroot} || $ENV{CVSROOT}; + my $cvs_site_perl = + $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL}; + if ($cvs_site_perl) { + $cvs_dir = "$cvs_site_perl/$cvs_dir"; + } + my $cvs_log = qq{"imported $package $version sources"}; + $version =~ s/\./_/g; + # XXX cvs: undocumented and unclear how it was meant to work + my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, + "$cvs_dir", $userid, "v$version"); + + my $pwd = CPAN::anycwd(); + chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); + + $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); + + $CPAN::Frontend->myprint(qq{@cmd\n}); + system(@cmd) == 0 or + # XXX cvs + $CPAN::Frontend->mydie("cvs import failed"); + chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); +} + +#-> sub CPAN::Distribution::readme ; +sub readme { + my($self) = @_; + my($dist) = $self->id; + my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/; + $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG; + my($local_file); + my($local_wanted) = + File::Spec->catfile( + $CPAN::Config->{keep_source_where}, + "authors", + "id", + split(/\//,"$sans.readme"), + ); + my $readme = "authors/id/$sans.readme"; + $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG; + $local_file = CPAN::FTP->localize($readme, + $local_wanted) + or $CPAN::Frontend->mydie(qq{No $sans.readme found}); + + if ($^O eq 'MacOS') { + Mac::BuildTools::launch_file($local_file); + return; + } + + my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; + my $pager = $CPAN::Config->{'pager'} || "cat"; + $fh_pager->open("|$pager") + or die "Could not open pager $pager\: $!"; + my $fh_readme = FileHandle->new; + $fh_readme->open($local_file) + or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!}); + $CPAN::Frontend->myprint(qq{ +Displaying file + $local_file +with pager "$pager" +}); + $fh_pager->print(<$fh_readme>); + $fh_pager->close; +} + +#-> sub CPAN::Distribution::verifyCHECKSUM ; +sub verifyCHECKSUM { + my($self) = @_; + EXCUSE: { + my @e; + $self->{CHECKSUM_STATUS} ||= ""; + $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + my($lc_want,$lc_file,@local,$basename); + @local = split(/\//,$self->id); + pop @local; + push @local, "CHECKSUMS"; + $lc_want = + File::Spec->catfile($CPAN::Config->{keep_source_where}, + "authors", "id", @local); + local($") = "/"; + if (my $size = -s $lc_want) { + $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG; + if ($self->CHECKSUM_check_file($lc_want,1)) { + return $self->{CHECKSUM_STATUS} = "OK"; + } + } + $lc_file = CPAN::FTP->localize("authors/id/@local", + $lc_want,1); + unless ($lc_file) { + $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); + $local[-1] .= ".gz"; + $lc_file = CPAN::FTP->localize("authors/id/@local", + "$lc_want.gz",1); + if ($lc_file) { + $lc_file =~ s/\.gz(?!\n)\Z//; + eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)}; + } else { + return; + } + } + if ($self->CHECKSUM_check_file($lc_file)) { + return $self->{CHECKSUM_STATUS} = "OK"; + } +} + +#-> sub CPAN::Distribution::SIG_check_file ; +sub SIG_check_file { + my($self,$chk_file) = @_; + my $rv = eval { Module::Signature::_verify($chk_file) }; + + if ($rv == Module::Signature::SIGNATURE_OK()) { + $CPAN::Frontend->myprint("Signature for $chk_file ok\n"); + return $self->{SIG_STATUS} = "OK"; + } else { + $CPAN::Frontend->myprint(qq{\nSignature invalid for }. + qq{distribution file. }. + qq{Please investigate.\n\n}. + $self->as_string, + $CPAN::META->instance( + 'CPAN::Author', + $self->cpan_userid + )->as_string); + + my $wrap = qq{I\'d recommend removing $chk_file. Its signature +is invalid. Maybe you have configured your 'urllist' with +a bad URL. Please check this array with 'o conf urllist', and +retry.}; + + $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); + } +} + +#-> sub CPAN::Distribution::CHECKSUM_check_file ; + +# sloppy is 1 when we have an old checksums file that maybe is good +# enough + +sub CHECKSUM_check_file { + my($self,$chk_file,$sloppy) = @_; + my($cksum,$file,$basename); + + $sloppy ||= 0; + $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG; + my $check_sigs = CPAN::HandleConfig->prefs_lookup($self, + q{check_sigs}); + if ($check_sigs) { + if ($CPAN::META->has_inst("Module::Signature")) { + $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG; + $self->SIG_check_file($chk_file); + } else { + $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG; + } + } + + $file = $self->{localfile}; + $basename = File::Basename::basename($file); + my $fh = FileHandle->new; + if (open $fh, $chk_file) { + local($/); + my $eval = <$fh>; + $eval =~ s/\015?\012/\n/g; + close $fh; + my($compmt) = Safe->new(); + $cksum = $compmt->reval($eval); + if ($@) { + rename $chk_file, "$chk_file.bad"; + Carp::confess($@) if $@; + } + } else { + Carp::carp "Could not open $chk_file for reading"; + } + + if (! ref $cksum or ref $cksum ne "HASH") { + $CPAN::Frontend->mywarn(qq{ +Warning: checksum file '$chk_file' broken. + +When trying to read that file I expected to get a hash reference +for further processing, but got garbage instead. +}); + my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no"); + $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); + $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken"; + return; + } elsif (exists $cksum->{$basename}{sha256}) { + $self->debug("Found checksum for $basename:" . + "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG; + + open($fh, $file); + binmode $fh; + my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256}); + $fh->close; + $fh = CPAN::Tarzip->TIEHANDLE($file); + + unless ($eq) { + my $dg = Digest::SHA->new(256); + my($data,$ref); + $ref = \$data; + while ($fh->READ($ref, 4096) > 0) { + $dg->add($data); + } + my $hexdigest = $dg->hexdigest; + $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'}; + } + + if ($eq) { + $CPAN::Frontend->myprint("Checksum for $file ok\n"); + return $self->{CHECKSUM_STATUS} = "OK"; + } else { + $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }. + qq{distribution file. }. + qq{Please investigate.\n\n}. + $self->as_string, + $CPAN::META->instance( + 'CPAN::Author', + $self->cpan_userid + )->as_string); + + my $wrap = qq{I\'d recommend removing $file. Its +checksum is incorrect. Maybe you have configured your 'urllist' with +a bad URL. Please check this array with 'o conf urllist', and +retry.}; + + $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap)); + + # former versions just returned here but this seems a + # serious threat that deserves a die + + # $CPAN::Frontend->myprint("\n\n"); + # sleep 3; + # return; + } + # close $fh if fileno($fh); + } else { + return if $sloppy; + unless ($self->{CHECKSUM_STATUS}) { + $CPAN::Frontend->mywarn(qq{ +Warning: No checksum for $basename in $chk_file. + +The cause for this may be that the file is very new and the checksum +has not yet been calculated, but it may also be that something is +going awry right now. +}); + my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes"); + $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n"); + } + $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file"; + return; + } +} + +#-> sub CPAN::Distribution::eq_CHECKSUM ; +sub eq_CHECKSUM { + my($self,$fh,$expect) = @_; + if ($CPAN::META->has_inst("Digest::SHA")) { + my $dg = Digest::SHA->new(256); + my($data); + while (read($fh, $data, 4096)) { + $dg->add($data); + } + my $hexdigest = $dg->hexdigest; + # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]"; + return $hexdigest eq $expect; + } + return 1; +} + +#-> sub CPAN::Distribution::force ; + +# Both CPAN::Modules and CPAN::Distributions know if "force" is in +# effect by autoinspection, not by inspecting a global variable. One +# of the reason why this was chosen to work that way was the treatment +# of dependencies. They should not automatically inherit the force +# status. But this has the downside that ^C and die() will return to +# the prompt but will not be able to reset the force_update +# attributes. We try to correct for it currently in the read_metadata +# routine, and immediately before we check for a Signal. I hope this +# works out in one of v1.57_53ff + +# "Force get forgets previous error conditions" + +#-> sub CPAN::Distribution::fforce ; +sub fforce { + my($self, $method) = @_; + $self->force($method,1); +} + +#-> sub CPAN::Distribution::force ; +sub force { + my($self, $method,$fforce) = @_; + my %phase_map = ( + get => [ + "unwrapped", + "build_dir", + "archived", + "localfile", + "CHECKSUM_STATUS", + "signature_verify", + "prefs", + "prefs_file", + "prefs_file_doc", + ], + make => [ + "writemakefile", + "make", + "modulebuild", + "prereq_pm", + "prereq_pm_detected", + ], + test => [ + "badtestcnt", + "make_test", + ], + install => [ + "install", + ], + unknown => [ + "reqtype", + "yaml_content", + ], + ); + my $methodmatch = 0; + my $ldebug = 0; + PHASE: for my $phase (qw(unknown get make test install)) { # order matters + $methodmatch = 1 if $fforce || $phase eq $method; + next unless $methodmatch; + ATTRIBUTE: for my $att (@{$phase_map{$phase}}) { + if ($phase eq "get") { + if (substr($self->id,-1,1) eq "." + && $att =~ /(unwrapped|build_dir|archived)/ ) { + # cannot be undone for local distros + next ATTRIBUTE; + } + if ($att eq "build_dir" + && $self->{build_dir} + && $CPAN::META->{is_tested} + ) { + delete $CPAN::META->{is_tested}{$self->{build_dir}}; + } + } elsif ($phase eq "test") { + if ($att eq "make_test" + && $self->{make_test} + && $self->{make_test}{COMMANDID} + && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId + ) { + # endless loop too likely + next ATTRIBUTE; + } + } + delete $self->{$att}; + if ($ldebug || $CPAN::DEBUG) { + # local $CPAN::DEBUG = 16; # Distribution + CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att); + } + } + } + if ($method && $method =~ /make|test|install/) { + $self->{force_update} = 1; # name should probably have been force_install + } +} + +#-> sub CPAN::Distribution::notest ; +sub notest { + my($self, $method) = @_; + # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method"); + $self->{"notest"}++; # name should probably have been force_install +} + +#-> sub CPAN::Distribution::unnotest ; +sub unnotest { + my($self) = @_; + # warn "XDEBUG: deleting notest"; + delete $self->{notest}; +} + +#-> sub CPAN::Distribution::unforce ; +sub unforce { + my($self) = @_; + delete $self->{force_update}; +} + +#-> sub CPAN::Distribution::isa_perl ; +sub isa_perl { + my($self) = @_; + my $file = File::Basename::basename($self->id); + if ($file =~ m{ ^ perl + -? + (5) + ([._-]) + ( + \d{3}(_[0-4][0-9])? + | + \d+\.\d+ + ) + \.tar[._-](?:gz|bz2) + (?!\n)\Z + }xs) { + return "$1.$3"; + } elsif ($self->cpan_comment + && + $self->cpan_comment =~ /isa_perl\(.+?\)/) { + return $1; + } +} + + +#-> sub CPAN::Distribution::perl ; +sub perl { + my ($self) = @_; + if (! $self) { + use Carp qw(carp); + carp __PACKAGE__ . "::perl was called without parameters."; + } + return CPAN::HandleConfig->safe_quote($CPAN::Perl); +} + + +#-> sub CPAN::Distribution::make ; +sub make { + my($self) = @_; + if (my $goto = $self->prefs->{goto}) { + return $self->goto($goto); + } + my $make = $self->{modulebuild} ? "Build" : "make"; + # Emergency brake if they said install Pippi and get newest perl + if ($self->isa_perl) { + if ( + $self->called_for ne $self->id && + ! $self->{force_update} + ) { + # if we die here, we break bundles + $CPAN::Frontend + ->mywarn(sprintf( + qq{The most recent version "%s" of the module "%s" +is part of the perl-%s distribution. To install that, you need to run + force install %s --or-- + install %s +}, + $CPAN::META->instance( + 'CPAN::Module', + $self->called_for + )->cpan_version, + $self->called_for, + $self->isa_perl, + $self->called_for, + $self->id, + )); + $self->{make} = CPAN::Distrostatus->new("NO isa perl"); + $CPAN::Frontend->mysleep(1); + return; + } + } + $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); + $self->get; + return if $self->prefs->{disabled} && ! $self->{force_update}; + if ($self->{configure_requires_later}) { + return; + } + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? $ENV{PERL5LIB} + : ($ENV{PERLLIB} || ""); + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; + $CPAN::META->set_perl5lib; + local $ENV{MAKEFLAGS}; # protect us from outer make calls + + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + + my $builddir; + EXCUSE: { + my @e; + if (!$self->{archived} || $self->{archived} eq "NO") { + push @e, "Is neither a tar nor a zip archive."; + } + + if (!$self->{unwrapped} + || ( + UNIVERSAL::can($self->{unwrapped},"failed") ? + $self->{unwrapped}->failed : + $self->{unwrapped} =~ /^NO/ + )) { + push @e, "Had problems unarchiving. Please build manually"; + } + + unless ($self->{force_update}) { + exists $self->{signature_verify} and + ( + UNIVERSAL::can($self->{signature_verify},"failed") ? + $self->{signature_verify}->failed : + $self->{signature_verify} =~ /^NO/ + ) + and push @e, "Did not pass the signature test."; + } + + if (exists $self->{writemakefile} && + ( + UNIVERSAL::can($self->{writemakefile},"failed") ? + $self->{writemakefile}->failed : + $self->{writemakefile} =~ /^NO/ + )) { + # XXX maybe a retry would be in order? + my $err = UNIVERSAL::can($self->{writemakefile},"text") ? + $self->{writemakefile}->text : + $self->{writemakefile}; + $err =~ s/^NO\s*(--\s+)?//; + $err ||= "Had some problem writing Makefile"; + $err .= ", won't make"; + push @e, $err; + } + + if (defined $self->{make}) { + if (UNIVERSAL::can($self->{make},"failed") ? + $self->{make}->failed : + $self->{make} =~ /^NO/) { + if ($self->{force_update}) { + # Trying an already failed 'make' (unless somebody else blocks) + } else { + # introduced for turning recursion detection into a distrostatus + my $error = length $self->{make}>3 + ? substr($self->{make},3) : "Unknown error"; + $CPAN::Frontend->mywarn("Could not make: $error\n"); + $self->store_persistent_state; + return; + } + } else { + push @e, "Has already been made"; + my $wait_for_prereqs = eval { $self->satisfy_requires }; + return 1 if $wait_for_prereqs; # tells queuerunner to continue + return $self->goodbye($@) if $@; # tells queuerunner to stop + } + } + + my $later = $self->{later} || $self->{configure_requires_later}; + if ($later) { # see also undelay + if ($later) { + push @e, $later; + } + } + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + $builddir = $self->dir or + $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n"); + unless (chdir $builddir) { + push @e, "Couldn't chdir to '$builddir': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; + } + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + $CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n"); + $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + Mac::BuildTools::make($self); + return; + } + + my %env; + while (my($k,$v) = each %ENV) { + next unless defined $v; + $env{$k} = $v; + } + local %ENV = %env; + my $system; + my $pl_commandline; + if ($self->prefs->{pl}) { + $pl_commandline = $self->prefs->{pl}{commandline}; + } + if ($pl_commandline) { + $system = $pl_commandline; + $ENV{PERL} = $^X; + } elsif ($self->{'configure'}) { + $system = $self->{'configure'}; + } elsif ($self->{modulebuild}) { + my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; + $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}"; + } else { + my($perl) = $self->perl or die "Couldn\'t find executable perl\n"; + my $switch = ""; +# This needs a handler that can be turned on or off: +# $switch = "-MExtUtils::MakeMaker ". +# "-Mops=:default,:filesys_read,:filesys_open,require,chdir" +# if $] > 5.00310; + my $makepl_arg = $self->_make_phase_arg("pl"); + $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir}, + "Makefile.PL"); + $system = sprintf("%s%s Makefile.PL%s", + $perl, + $switch ? " $switch" : "", + $makepl_arg ? " $makepl_arg" : "", + ); + } + my $pl_env; + if ($self->prefs->{pl}) { + $pl_env = $self->prefs->{pl}{env}; + } + if ($pl_env) { + for my $e (keys %$pl_env) { + $ENV{$e} = $pl_env->{$e}; + } + } + if (exists $self->{writemakefile}) { + } else { + local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; + my($ret,$pid,$output); + $@ = ""; + my $go_via_alarm; + if ($CPAN::Config->{inactivity_timeout}) { + require Config; + if ($Config::Config{d_alarm} + && + $Config::Config{d_alarm} eq "define" + ) { + $go_via_alarm++ + } else { + $CPAN::Frontend->mywarn("Warning: you have configured the config ". + "variable 'inactivity_timeout' to ". + "'$CPAN::Config->{inactivity_timeout}'. But ". + "on this machine the system call 'alarm' ". + "isn't available. This means that we cannot ". + "provide the feature of intercepting long ". + "waiting code and will turn this feature off.\n" + ); + $CPAN::Config->{inactivity_timeout} = 0; + } + } + if ($go_via_alarm) { + if ( $self->_should_report('pl') ) { + ($output, $ret) = CPAN::Reporter::record_command( + $system, + $CPAN::Config->{inactivity_timeout}, + ); + CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); + } + else { + eval { + alarm $CPAN::Config->{inactivity_timeout}; + local $SIG{CHLD}; # = sub { wait }; + if (defined($pid = fork)) { + if ($pid) { #parent + # wait; + waitpid $pid, 0; + } else { #child + # note, this exec isn't necessary if + # inactivity_timeout is 0. On the Mac I'd + # suggest, we set it always to 0. + exec $system; + } + } else { + $CPAN::Frontend->myprint("Cannot fork: $!"); + return; + } + }; + alarm 0; + if ($@) { + kill 9, $pid; + waitpid $pid, 0; + my $err = "$@"; + $CPAN::Frontend->myprint($err); + $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); + $@ = ""; + $self->store_persistent_state; + return $self->goodbye("$system -- TIMED OUT"); + } + } + } else { + if (my $expect_model = $self->_prefs_with_expect("pl")) { + # XXX probably want to check _should_report here and warn + # about not being able to use CPAN::Reporter with expect + $ret = $self->_run_via_expect($system,'writemakefile',$expect_model); + if (! defined $ret + && $self->{writemakefile} + && $self->{writemakefile}->failed) { + # timeout + return; + } + } + elsif ( $self->_should_report('pl') ) { + ($output, $ret) = CPAN::Reporter::record_command($system); + CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); + } + else { + $ret = system($system); + } + if ($ret != 0) { + $self->{writemakefile} = CPAN::Distrostatus + ->new("NO '$system' returned status $ret"); + $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n"); + $self->store_persistent_state; + return $self->goodbye("$system -- NOT OK"); + } + } + if (-f "Makefile" || -f "Build") { + $self->{writemakefile} = CPAN::Distrostatus->new("YES"); + delete $self->{make_clean}; # if cleaned before, enable next + } else { + my $makefile = $self->{modulebuild} ? "Build" : "Makefile"; + my $why = "No '$makefile' created"; + $CPAN::Frontend->mywarn($why); + $self->{writemakefile} = CPAN::Distrostatus + ->new(qq{NO -- $why\n}); + $self->store_persistent_state; + return $self->goodbye("$system -- NOT OK"); + } + } + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + my $wait_for_prereqs = eval { $self->satisfy_requires }; + return 1 if $wait_for_prereqs; # tells queuerunner to continue + return $self->goodbye($@) if $@; # tells queuerunner to stop + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + my $make_commandline; + if ($self->prefs->{make}) { + $make_commandline = $self->prefs->{make}{commandline}; + } + if ($make_commandline) { + $system = $make_commandline; + $ENV{PERL} = CPAN::find_perl(); + } else { + if ($self->{modulebuild}) { + unless (-f "Build") { + my $cwd = CPAN::anycwd(); + $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'". + " in cwd[$cwd]. Danger, Will Robinson!\n"); + $CPAN::Frontend->mysleep(5); + } + $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg}; + } else { + $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; + } + $system =~ s/\s+$//; + my $make_arg = $self->_make_phase_arg("make"); + $system = sprintf("%s%s", + $system, + $make_arg ? " $make_arg" : "", + ); + } + my $make_env; + if ($self->prefs->{make}) { + $make_env = $self->prefs->{make}{env}; + } + if ($make_env) { # overriding the local ENV of PL, not the outer + # ENV, but unlikely to be a risk + for my $e (keys %$make_env) { + $ENV{$e} = $make_env->{$e}; + } + } + my $expect_model = $self->_prefs_with_expect("make"); + my $want_expect = 0; + if ( $expect_model && @{$expect_model->{talk}} ) { + my $can_expect = $CPAN::META->has_inst("Expect"); + if ($can_expect) { + $want_expect = 1; + } else { + $CPAN::Frontend->mywarn("Expect not installed, falling back to ". + "system()\n"); + } + } + my $system_ok; + if ($want_expect) { + # XXX probably want to check _should_report here and + # warn about not being able to use CPAN::Reporter with expect + $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0; + } + elsif ( $self->_should_report('make') ) { + my ($output, $ret) = CPAN::Reporter::record_command($system); + CPAN::Reporter::grade_make( $self, $system, $output, $ret ); + $system_ok = ! $ret; + } + else { + $system_ok = system($system) == 0; + } + $self->introduce_myself; + if ( $system_ok ) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{make} = CPAN::Distrostatus->new("YES"); + } else { + $self->{writemakefile} ||= CPAN::Distrostatus->new("YES"); + $self->{make} = CPAN::Distrostatus->new("NO"); + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + } + $self->store_persistent_state; +} + +# CPAN::Distribution::goodbye ; +sub goodbye { + my($self,$goodbye) = @_; + my $id = $self->pretty_id; + $CPAN::Frontend->mywarn(" $id\n $goodbye\n"); + return; +} + +# CPAN::Distribution::_run_via_expect ; +sub _run_via_expect { + my($self,$system,$phase,$expect_model) = @_; + CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG; + if ($CPAN::META->has_inst("Expect")) { + my $expo = Expect->new; # expo Expect object; + $expo->spawn($system); + $expect_model->{mode} ||= "deterministic"; + if ($expect_model->{mode} eq "deterministic") { + return $self->_run_via_expect_deterministic($expo,$phase,$expect_model); + } elsif ($expect_model->{mode} eq "anyorder") { + return $self->_run_via_expect_anyorder($expo,$phase,$expect_model); + } else { + die "Panic: Illegal expect mode: $expect_model->{mode}"; + } + } else { + $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n"); + return system($system); + } +} + +sub _run_via_expect_anyorder { + my($self,$expo,$phase,$expect_model) = @_; + my $timeout = $expect_model->{timeout} || 5; + my $reuse = $expect_model->{reuse}; + my @expectacopy = @{$expect_model->{talk}}; # we trash it! + my $but = ""; + my $timeout_start = time; + EXPECT: while () { + my($eof,$ran_into_timeout); + # XXX not up to the full power of expect. one could certainly + # wrap all of the talk pairs into a single expect call and on + # success tweak it and step ahead to the next question. The + # current implementation unnecessarily limits itself to a + # single match. + my @match = $expo->expect(1, + [ eof => sub { + $eof++; + } ], + [ timeout => sub { + $ran_into_timeout++; + } ], + -re => eval"qr{.}", + ); + if ($match[2]) { + $but .= $match[2]; + } + $but .= $expo->clear_accum; + if ($eof) { + $expo->soft_close; + return $expo->exitstatus(); + } elsif ($ran_into_timeout) { + # warn "DEBUG: they are asking a question, but[$but]"; + for (my $i = 0; $i <= $#expectacopy; $i+=2) { + my($next,$send) = @expectacopy[$i,$i+1]; + my $regex = eval "qr{$next}"; + # warn "DEBUG: will compare with regex[$regex]."; + if ($but =~ /$regex/) { + # warn "DEBUG: will send send[$send]"; + $expo->send($send); + # never allow reusing an QA pair unless they told us + splice @expectacopy, $i, 2 unless $reuse; + $but =~ s/(?s:^.*?)$regex//; + $timeout_start = time; + next EXPECT; + } + } + my $have_waited = time - $timeout_start; + if ($have_waited < $timeout) { + # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]"; + next EXPECT; + } + my $why = "could not answer a question during the dialog"; + $CPAN::Frontend->mywarn("Failing: $why\n"); + $self->{$phase} = + CPAN::Distrostatus->new("NO $why"); + return 0; + } + } +} + +sub _run_via_expect_deterministic { + my($self,$expo,$phase,$expect_model) = @_; + my $ran_into_timeout; + my $ran_into_eof; + my $timeout = $expect_model->{timeout} || 15; # currently unsettable + my $expecta = $expect_model->{talk}; + EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) { + my($re,$send) = @$expecta[$i,$i+1]; + CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG; + my $regex = eval "qr{$re}"; + $expo->expect($timeout, + [ eof => sub { + my $but = $expo->clear_accum; + $CPAN::Frontend->mywarn("EOF (maybe harmless) +expected[$regex]\nbut[$but]\n\n"); + $ran_into_eof++; + } ], + [ timeout => sub { + my $but = $expo->clear_accum; + $CPAN::Frontend->mywarn("TIMEOUT +expected[$regex]\nbut[$but]\n\n"); + $ran_into_timeout++; + } ], + -re => $regex); + if ($ran_into_timeout) { + # note that the caller expects 0 for success + $self->{$phase} = + CPAN::Distrostatus->new("NO timeout during expect dialog"); + return 0; + } elsif ($ran_into_eof) { + last EXPECT; + } + $expo->send($send); + } + $expo->soft_close; + return $expo->exitstatus(); +} + +#-> CPAN::Distribution::_validate_distropref +sub _validate_distropref { + my($self,@args) = @_; + if ( + $CPAN::META->has_inst("CPAN::Kwalify") + && + $CPAN::META->has_inst("Kwalify") + ) { + eval {CPAN::Kwalify::_validate("distroprefs",@args);}; + if ($@) { + $CPAN::Frontend->mywarn($@); + } + } else { + CPAN->debug("not validating '@args'") if $CPAN::DEBUG; + } +} + +#-> CPAN::Distribution::_find_prefs +sub _find_prefs { + my($self) = @_; + my $distroid = $self->pretty_id; + #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG; + my $prefs_dir = $CPAN::Config->{prefs_dir}; + return if $prefs_dir =~ /^\s*$/; + eval { File::Path::mkpath($prefs_dir); }; + if ($@) { + $CPAN::Frontend->mydie("Cannot create directory $prefs_dir"); + } + 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->mywarn("'$yaml_module' not installed, falling back ". + "to @fallbacks to read prefs '$prefs_dir'\n"); + } + } else { + unless ($self->{have_complained_about_missing_yaml}++) { + $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ". + "read prefs '$prefs_dir'\n"); + } + } + } + my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map); + DIRENT: while (my $result = $finder->next) { + if ($result->is_warning) { + $CPAN::Frontend->mywarn($result->as_string); + $CPAN::Frontend->mysleep(1); + next DIRENT; + } elsif ($result->is_fatal) { + $CPAN::Frontend->mydie($result->as_string); + } + + my @prefs = @{ $result->prefs }; + + ELEMENT: for my $y (0..$#prefs) { + my $pref = $prefs[$y]; + $self->_validate_distropref($pref->data, $result->abs, $y); + + # I don't know why we silently skip when there's no match, but + # complain if there's an empty match hashref, and there's no + # comment explaining why -- hdp, 2008-03-18 + unless ($pref->has_any_match) { + next ELEMENT; + } + + unless ($pref->has_valid_subkeys) { + $CPAN::Frontend->mydie(sprintf + "Nonconforming .%s file '%s': " . + "missing match/* subattribute. " . + "Please remove, cannot continue.", + $result->ext, $result->abs, + ); + } + + my $arg = { + env => \%ENV, + distribution => $distroid, + perl => \&CPAN::find_perl, + perlconfig => \%Config::Config, + module => sub { [ $self->containsmods ] }, + }; + + if ($pref->matches($arg)) { + return { + prefs => $pref->data, + prefs_file => $result->abs, + prefs_file_doc => $y, + }; + } + + } + } + return; +} + +# CPAN::Distribution::prefs +sub prefs { + my($self) = @_; + if (exists $self->{negative_prefs_cache} + && + $self->{negative_prefs_cache} != $CPAN::CurrentCommandId + ) { + delete $self->{negative_prefs_cache}; + delete $self->{prefs}; + } + if (exists $self->{prefs}) { + return $self->{prefs}; # XXX comment out during debugging + } + if ($CPAN::Config->{prefs_dir}) { + CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG; + my $prefs = $self->_find_prefs(); + $prefs ||= ""; # avoid warning next line + CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG; + if ($prefs) { + for my $x (qw(prefs prefs_file prefs_file_doc)) { + $self->{$x} = $prefs->{$x}; + } + my $bs = sprintf( + "%s[%s]", + File::Basename::basename($self->{prefs_file}), + $self->{prefs_file_doc}, + ); + my $filler1 = "_" x 22; + my $filler2 = int(66 - length($bs))/2; + $filler2 = 0 if $filler2 < 0; + $filler2 = " " x $filler2; + $CPAN::Frontend->myprint(" +$filler1 D i s t r o P r e f s $filler1 +$filler2 $bs $filler2 +"); + $CPAN::Frontend->mysleep(1); + return $self->{prefs}; + } + } + $self->{negative_prefs_cache} = $CPAN::CurrentCommandId; + return $self->{prefs} = +{}; +} + +# CPAN::Distribution::_make_phase_arg +sub _make_phase_arg { + my($self, $phase) = @_; + my $_make_phase_arg; + my $prefs = $self->prefs; + if ( + $prefs + && exists $prefs->{$phase} + && exists $prefs->{$phase}{args} + && $prefs->{$phase}{args} + ) { + $_make_phase_arg = join(" ", + map {CPAN::HandleConfig + ->safe_quote($_)} @{$prefs->{$phase}{args}}, + ); + } + +# cpan[2]> o conf make[TAB] +# make make_install_make_command +# make_arg makepl_arg +# make_install_arg +# cpan[2]> o conf mbuild[TAB] +# mbuild_arg mbuild_install_build_command +# mbuild_install_arg mbuildpl_arg + + my $mantra; # must switch make/mbuild here + if ($self->{modulebuild}) { + $mantra = "mbuild"; + } else { + $mantra = "make"; + } + my %map = ( + pl => "pl_arg", + make => "_arg", + test => "_test_arg", # does not really exist but maybe + # will some day and now protects + # us from unini warnings + install => "_install_arg", + ); + my $phase_underscore_meshup = $map{$phase}; + my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup; + + $_make_phase_arg ||= $CPAN::Config->{$what}; + return $_make_phase_arg; +} + +# CPAN::Distribution::_make_command +sub _make_command { + my ($self) = @_; + if ($self) { + return + CPAN::HandleConfig + ->safe_quote( + CPAN::HandleConfig->prefs_lookup($self, + q{make}) + || $Config::Config{make} + || 'make' + ); + } else { + # Old style call, without object. Deprecated + Carp::confess("CPAN::_make_command() used as function. Don't Do That."); + return + safe_quote(undef, + CPAN::HandleConfig->prefs_lookup($self,q{make}) + || $CPAN::Config->{make} + || $Config::Config{make} + || 'make'); + } +} + +#-> sub CPAN::Distribution::follow_prereqs ; +sub follow_prereqs { + my($self) = shift; + my($slot) = shift; + my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; + return unless @prereq_tuples; + my(@good_prereq_tuples); + for my $p (@prereq_tuples) { + # XXX watch out for foul ones + push @good_prereq_tuples, $p; + } + my $pretty_id = $self->pretty_id; + my %map = ( + b => "build_requires", + r => "requires", + c => "commandline", + ); + my($filler1,$filler2,$filler3,$filler4); + my $unsat = "Unsatisfied dependencies detected during"; + my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id); + { + my $r = int(($w - length($unsat))/2); + my $l = $w - length($unsat) - $r; + $filler1 = "-"x4 . " "x$l; + $filler2 = " "x$r . "-"x4 . "\n"; + } + { + my $r = int(($w - length($pretty_id))/2); + my $l = $w - length($pretty_id) - $r; + $filler3 = "-"x4 . " "x$l; + $filler4 = " "x$r . "-"x4 . "\n"; + } + $CPAN::Frontend-> + myprint("$filler1 $unsat $filler2". + "$filler3 $pretty_id $filler4". + join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples), + ); + my $follow = 0; + if ($CPAN::Config->{prerequisites_policy} eq "follow") { + $follow = 1; + } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") { + my $answer = CPAN::Shell::colorable_makemaker_prompt( +"Shall I follow them and prepend them to the queue +of modules we are processing right now?", "yes"); + $follow = $answer =~ /^\s*y/i; + } else { + my @prereq = map { $_=>[0] } @good_prereq_tuples; + local($") = ", "; + $CPAN::Frontend-> + myprint(" Ignoring dependencies on modules @prereq\n"); + } + if ($follow) { + my $id = $self->id; + # color them as dirty + for my $gp (@good_prereq_tuples) { + # warn "calling color_cmd_tmps(0,1)"; + my $p = $gp->[0]; + my $any = CPAN::Shell->expandany($p); + $self->{$slot . "_for"}{$any->id}++; + if ($any) { + $any->color_cmd_tmps(0,2); + } else { + $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n"); + $CPAN::Frontend->mysleep(2); + } + } + # queue them and re-queue yourself + CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}}, + map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @good_prereq_tuples); + $self->{$slot} = "Delayed until after prerequisites"; + return 1; # signal success to the queuerunner + } + return; +} + +sub _feature_depends { + my($self) = @_; + my $meta_yml = $self->parse_meta_yml(); + my $optf = $meta_yml->{optional_features} or return; + if (!ref $optf or ref $optf ne "HASH"){ + $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n"); + $optf = {}; + } + my $wantf = $self->prefs->{features} or return; + if (!ref $wantf or ref $wantf ne "ARRAY"){ + $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n"); + $wantf = []; + } + my $dep = +{}; + for my $wf (@$wantf) { + if (my $f = $optf->{$wf}) { + $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ". + "is accompanied by this description:\n". + $f->{description}. + "\n\n" + ); + # configure_requires currently not in the spec, unlikely to be useful anyway + for my $reqtype (qw(configure_requires build_requires requires)) { + my $reqhash = $f->{$reqtype} or next; + while (my($k,$v) = each %$reqhash) { + $dep->{$reqtype}{$k} = $v; + } + } + } else { + $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ". + "found in the META.yml file". + "\n\n" + ); + } + } + $dep; +} + +#-> sub CPAN::Distribution::unsat_prereq ; +# return ([Foo,"r"],[Bar,"b"]) for normal modules +# return ([perl=>5.008]) if we need a newer perl than we are running under +# (sorry for the inconsistency, it was an accident) +sub unsat_prereq { + my($self,$slot) = @_; + my(%merged,$prereq_pm); + my $prefs_depends = $self->prefs->{depends}||{}; + my $feature_depends = $self->_feature_depends(); + if ($slot eq "configure_requires_later") { + my $meta_yml = $self->parse_meta_yml(); + if (defined $meta_yml && (! ref $meta_yml || ref $meta_yml ne "HASH")) { + $CPAN::Frontend->mywarn("The content of META.yml is defined but not a HASH reference. Cannot use it.\n"); + $meta_yml = +{}; + } + %merged = ( + %{$meta_yml->{configure_requires}||{}}, + %{$prefs_depends->{configure_requires}||{}}, + %{$feature_depends->{configure_requires}||{}}, + ); + $prereq_pm = {}; # configure_requires defined as "b" + } elsif ($slot eq "later") { + my $prereq_pm_0 = $self->prereq_pm || {}; + for my $reqtype (qw(requires build_requires)) { + $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it + for my $dep ($prefs_depends,$feature_depends) { + for my $k (keys %{$dep->{$reqtype}||{}}) { + $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k}; + } + } + } + %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); + } else { + die "Panic: illegal slot '$slot'"; + } + my(@need); + my @merged = %merged; + CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG; + NEED: while (my($need_module, $need_version) = each %merged) { + my($available_version,$inst_file,$available_file,$nmo); + if ($need_module eq "perl") { + $available_version = $]; + $available_file = CPAN::find_perl(); + } else { + if (CPAN::_sqlite_running()) { + CPAN::Index->reload; + $CPAN::SQLite->search("CPAN::Module",$need_module); + } + $nmo = $CPAN::META->instance("CPAN::Module",$need_module); + next if $nmo->uptodate; + $inst_file = $nmo->inst_file || ''; + $available_file = $nmo->available_file || ''; + + # if they have not specified a version, we accept any installed one + if ( $available_file + and ( # a few quick shortcurcuits + not defined $need_version + or $need_version eq '0' # "==" would trigger warning when not numeric + or $need_version eq "undef" + )) { + next NEED; + } + + $available_version = $nmo->available_version; + } + + # We only want to install prereqs if either they're not installed + # or if the installed version is too old. We cannot omit this + # check, because if 'force' is in effect, nobody else will check. + # But we don't want to accept a deprecated module installed as part + # of the Perl core, so we continue if the available file is the installed + # one and is deprecated + + if ( $available_file ) { + if ( $inst_file && $available_file eq $inst_file && $nmo->inst_deprecated ) { + # continue installing as a prereq + } + else { + next NEED if $self->_fulfills_all_version_rqs( + $need_module,$available_file,$available_version,$need_version + ); + } + } + + if ($need_module eq "perl") { + return ["perl", $need_version]; + } + $self->{sponsored_mods}{$need_module} ||= 0; + CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG; + if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) { + # We have already sponsored it and for some reason it's still + # not available. So we do ... what?? + + # if we push it again, we have a potential infinite loop + + # The following "next" was a very problematic construct. + # It helped a lot but broke some day and had to be + # replaced. + + # We must be able to deal with modules that come again and + # again as a prereq and have themselves prereqs and the + # queue becomes long but finally we would find the correct + # order. The RecursiveDependency check should trigger a + # die when it's becoming too weird. Unfortunately removing + # this next breaks many other things. + + # The bug that brought this up is described in Todo under + # "5.8.9 cannot install Compress::Zlib" + + # next; # this is the next that had to go away + + # The following "next NEED" are fine and the error message + # explains well what is going on. For example when the DBI + # fails and consequently DBD::SQLite fails and now we are + # processing CPAN::SQLite. Then we must have a "next" for + # DBD::SQLite. How can we get it and how can we identify + # all other cases we must identify? + + my $do = $nmo->distribution; + next NEED unless $do; # not on CPAN + if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){ + $CPAN::Frontend->mywarn("Warning: Prerequisite ". + "'$need_module => $need_version' ". + "for '$self->{ID}' seems ". + "not available according to the indices\n" + ); + next NEED; + } + NOSAYER: for my $nosayer ( + "unwrapped", + "writemakefile", + "signature_verify", + "make", + "make_test", + "install", + "make_clean", + ) { + if ($do->{$nosayer}) { + my $selfid = $self->pretty_id; + my $did = $do->pretty_id; + if (UNIVERSAL::can($do->{$nosayer},"failed") ? + $do->{$nosayer}->failed : + $do->{$nosayer} =~ /^NO/) { + if ($nosayer eq "make_test" + && + $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId + ) { + next NOSAYER; + } + $CPAN::Frontend->mywarn("Warning: Prerequisite ". + "'$need_module => $need_version' ". + "for '$selfid' failed when ". + "processing '$did' with ". + "'$nosayer => $do->{$nosayer}'. Continuing, ". + "but chances to succeed are limited.\n" + ); + $CPAN::Frontend->mysleep($sponsoring/10); + next NEED; + } else { # the other guy succeeded + if ($nosayer =~ /^(install|make_test)$/) { + # we had this with + # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz + # in 2007-03 for 'make install' + # and 2008-04: #30464 (for 'make test') + $CPAN::Frontend->mywarn("Warning: Prerequisite ". + "'$need_module => $need_version' ". + "for '$selfid' already built ". + "but the result looks suspicious. ". + "Skipping another build attempt, ". + "to prevent looping endlessly.\n" + ); + next NEED; + } + } + } + } + } + my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b"; + push @need, [$need_module,$needed_as]; + } + my @unfolded = map { "[".join(",",@$_)."]" } @need; + CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG; + @need; +} + +sub _fulfills_all_version_rqs { + my($self,$need_module,$available_file,$available_version,$need_version) = @_; + my(@all_requirements) = split /\s*,\s*/, $need_version; + local($^W) = 0; + my $ok = 0; + RQ: for my $rq (@all_requirements) { + if ($rq =~ s|>=\s*||) { + } elsif ($rq =~ s|>\s*||) { + # 2005-12: one user + if (CPAN::Version->vgt($available_version,$rq)) { + $ok++; + } + next RQ; + } elsif ($rq =~ s|!=\s*||) { + # 2005-12: no user + if (CPAN::Version->vcmp($available_version,$rq)) { + $ok++; + next RQ; + } else { + $ok=0; + last RQ; + } + } elsif ($rq =~ m|<=?\s*|) { + # 2005-12: no user + $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); + $ok++; + next RQ; + } elsif ($rq =~ s|==\s*||) { + # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz + if (CPAN::Version->vcmp($available_version,$rq)) { + $ok=0; + last RQ; + } else { + $ok++; + next RQ; + } + } + if (! CPAN::Version->vgt($rq, $available_version)) { + $ok++; + } + CPAN->debug(sprintf("need_module[%s]available_file[%s]". + "available_version[%s]rq[%s]ok[%d]", + $need_module, + $available_file, + $available_version, + CPAN::Version->readable($rq), + $ok, + )) if $CPAN::DEBUG; + } + my $ret = $ok == @all_requirements; + CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG; + return $ret; +} + +#-> sub CPAN::Distribution::read_yaml ; +sub read_yaml { + my($self) = @_; + return $self->{yaml_content} if exists $self->{yaml_content}; + 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; + } + # if MYMETA.yml exists, that takes precedence over META.yml + my $meta = File::Spec->catfile($build_dir,"META.yml"); + my $mymeta = File::Spec->catfile($build_dir,"MYMETA.yml"); + my $yaml = -f $mymeta ? $mymeta : $meta; + $self->debug("yaml[$yaml]") if $CPAN::DEBUG; + return unless -f $yaml; + eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; }; + if ($@) { + $CPAN::Frontend->mywarn("Could not read ". + "'$yaml'. Falling back to other ". + "methods to determine prerequisites\n"); + return $self->{yaml_content} = undef; # if we die, then we + # cannot read YAML's own + # META.yml + } + # not "authoritative" + for ($self->{yaml_content}) { + if (defined $_ && (! ref $_ || ref $_ ne "HASH")) { + $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n"); + $self->{yaml_content} = +{}; + } + } + # MYMETA.yml is not dynamic by definition + if ( $yaml ne $mymeta && + ( not exists $self->{yaml_content}{dynamic_config} + or $self->{yaml_content}{dynamic_config} + ) + ) { + $self->{yaml_content} = undef; + } + $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF") + if $CPAN::DEBUG; + return $self->{yaml_content}; +} + +#-> sub CPAN::Distribution::prereq_pm ; +sub prereq_pm { + my($self) = @_; + $self->{prereq_pm_detected} ||= 0; + CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG; + return $self->{prereq_pm} if $self->{prereq_pm_detected}; + return unless $self->{writemakefile} # no need to have succeeded + # but we must have run it + || $self->{modulebuild}; + unless ($self->{build_dir}) { + return; + } + CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]", + $self->{writemakefile}||"", + $self->{modulebuild}||"", + ) if $CPAN::DEBUG; + my($req,$breq); + if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here + $req = $yaml->{requires} || {}; + $breq = $yaml->{build_requires} || {}; + undef $req unless ref $req eq "HASH" && %$req; + if ($req) { + if ($yaml->{generated_by} && + $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { + my $eummv = do { local $^W = 0; $1+0; }; + if ($eummv < 6.2501) { + # thanks to Slaven for digging that out: MM before + # that could be wrong because it could reflect a + # previous release + undef $req; + } + } + my $areq; + my $do_replace; + while (my($k,$v) = each %{$req||{}}) { + 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; + } + } + unless ($req || $breq) { + my $build_dir; + unless ( $build_dir = $self->{build_dir} ) { + return; + } + my $makefile = File::Spec->catfile($build_dir,"Makefile"); + my $fh; + if (-f $makefile + and + $fh = FileHandle->new("<$makefile\0")) { + CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG; + local($/) = "\n"; + while (<$fh>) { + last if /MakeMaker post_initialize section/; + my($p) = m{^[\#] + \s+PREREQ_PM\s+=>\s+(.+) + }x; + next unless $p; + # warn "Found prereq expr[$p]"; + + # Regexp modified by A.Speer to remember actual version of file + # PREREQ_PM hash key wants, then add to + while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) { + my($m,$n) = ($1,$2); + # When a prereq is mentioned twice: let the bigger + # win; usual culprit is that they declared + # build_requires separately from requires; see + # rt.cpan.org #47774 + my($prevn); + if ( defined $req->{$m} ) { + $prevn = $req->{$m}; + } + if ($n =~ /^q\[(.*?)\]$/) { + $n = $1; + } + if (!$prevn || CPAN::Version->vlt($prevn, $n)){ + $req->{$m} = $n; + } + } + last; + } + } + } + unless ($req || $breq) { + my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; + my $buildfile = File::Spec->catfile($build_dir,"Build"); + if (-f $buildfile) { + CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG; + my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs"); + if (-f $build_prereqs) { + CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG; + my $content = do { local *FH; + open FH, $build_prereqs + or $CPAN::Frontend->mydie("Could not open ". + "'$build_prereqs': $!"); + local $/; + <FH>; + }; + my $bphash = eval $content; + if ($@) { + } else { + $req = $bphash->{requires} || +{}; + $breq = $bphash->{build_requires} || +{}; + } + } + } + } + if (-f "Build.PL" + && ! -f "Makefile.PL" + && ! exists $req->{"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); + $req->{"Module::Build"} = 0; + delete $self->{writemakefile}; + } + if ($req || $breq) { + $self->{prereq_pm_detected}++; + return $self->{prereq_pm} = { requires => $req, build_requires => $breq }; + } +} + +#-> sub CPAN::Distribution::test ; +sub test { + my($self) = @_; + if (my $goto = $self->prefs->{goto}) { + return $self->goto($goto); + } + $self->make; + return if $self->prefs->{disabled} && ! $self->{force_update}; + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + # warn "XDEBUG: checking for notest: $self->{notest} $self"; + if ($self->{notest}) { + $CPAN::Frontend->myprint("Skipping test because of notest pragma\n"); + return 1; + } + + my $make = $self->{modulebuild} ? "Build" : "make"; + + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? $ENV{PERL5LIB} + : ($ENV{PERLLIB} || ""); + + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; + $CPAN::META->set_perl5lib; + local $ENV{MAKEFLAGS}; # protect us from outer make calls + + $CPAN::Frontend->myprint("Running $make test\n"); + + EXCUSE: { + my @e; + if ($self->{make} or $self->{later}) { + # go ahead + } else { + push @e, + "Make had some problems, won't test"; + } + + exists $self->{make} and + ( + UNIVERSAL::can($self->{make},"failed") ? + $self->{make}->failed : + $self->{make} =~ /^NO/ + ) and push @e, "Can't test without successful make"; + $self->{badtestcnt} ||= 0; + if ($self->{badtestcnt} > 0) { + require Data::Dumper; + CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG; + push @e, "Won't repeat unsuccessful test during this command"; + } + + push @e, $self->{later} if $self->{later}; + push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; + + if (exists $self->{build_dir}) { + if (exists $self->{make_test}) { + if ( + UNIVERSAL::can($self->{make_test},"failed") ? + $self->{make_test}->failed : + $self->{make_test} =~ /^NO/ + ) { + if ( + UNIVERSAL::can($self->{make_test},"commandid") + && + $self->{make_test}->commandid == $CPAN::CurrentCommandId + ) { + push @e, "Has already been tested within this command"; + } + } else { + push @e, "Has already been tested successfully"; + # if global "is_tested" has been cleared, we need to mark this to + # be added to PERL5LIB if not already installed + if ($self->tested_ok_but_not_installed) { + $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); + } + } + } + } elsif (!@e) { + push @e, "Has no own directory"; + } + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + unless (chdir $self->{build_dir}) { + push @e, "Couldn't chdir to '$self->{build_dir}': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; + } + $self->debug("Changed directory to $self->{build_dir}") + if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + Mac::BuildTools::make_test($self); + return; + } + + if ($self->{modulebuild}) { + my $thm = CPAN::Shell->expand("Module","Test::Harness"); + my $v = $thm->inst_version; + if (CPAN::Version->vlt($v,2.62)) { + # XXX Eric Wilhelm reported this as a bug: klapperl: + # Test::Harness 3.0 self-tests, so that should be 'unless + # installing Test::Harness' + unless ($self->id eq $thm->distribution->id) { + $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only + '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); + $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); + return; + } + } + } + + if ( ! $self->{force_update} ) { + # bypass actual tests if "trust_test_report_history" and have a report + my $have_tested_fcn; + if ( $CPAN::Config->{trust_test_report_history} + && $CPAN::META->has_inst("CPAN::Reporter::History") + && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) { + if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) { + # Do nothing if grade was DISCARD + if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) { + $self->{make_test} = CPAN::Distrostatus->new("YES"); + # if global "is_tested" has been cleared, we need to mark this to + # be added to PERL5LIB if not already installed + if ($self->tested_ok_but_not_installed) { + $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); + } + $CPAN::Frontend->myprint("Found prior test report -- OK\n"); + return; + } + elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) { + $self->{make_test} = CPAN::Distrostatus->new("NO"); + $self->{badtestcnt}++; + $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n"); + return; + } + } + } + } + + my $system; + my $prefs_test = $self->prefs->{test}; + if (my $commandline + = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") { + $system = $commandline; + $ENV{PERL} = CPAN::find_perl(); + } elsif ($self->{modulebuild}) { + $system = sprintf "%s test", $self->_build_command(); + unless (-e "Build") { + my $id = $self->pretty_id; + $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'"); + } + } else { + $system = join " ", $self->_make_command(), "test"; + } + my $make_test_arg = $self->_make_phase_arg("test"); + $system = sprintf("%s%s", + $system, + $make_test_arg ? " $make_test_arg" : "", + ); + my($tests_ok); + my %env; + while (my($k,$v) = each %ENV) { + next unless defined $v; + $env{$k} = $v; + } + local %ENV = %env; + my $test_env; + if ($self->prefs->{test}) { + $test_env = $self->prefs->{test}{env}; + } + if ($test_env) { + for my $e (keys %$test_env) { + $ENV{$e} = $test_env->{$e}; + } + } + my $expect_model = $self->_prefs_with_expect("test"); + my $want_expect = 0; + if ( $expect_model && @{$expect_model->{talk}} ) { + my $can_expect = $CPAN::META->has_inst("Expect"); + if ($can_expect) { + $want_expect = 1; + } else { + $CPAN::Frontend->mywarn("Expect not installed, falling back to ". + "testing without\n"); + } + } + if ($want_expect) { + if ($self->_should_report('test')) { + $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". + "not supported when distroprefs specify ". + "an interactive test\n"); + } + $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; + } elsif ( $self->_should_report('test') ) { + $tests_ok = CPAN::Reporter::test($self, $system); + } else { + $tests_ok = system($system) == 0; + } + $self->introduce_myself; + if ( $tests_ok ) { + { + my @prereq; + + # local $CPAN::DEBUG = 16; # Distribution + for my $m (keys %{$self->{sponsored_mods}}) { + next unless $self->{sponsored_mods}{$m} > 0; + my $m_obj = CPAN::Shell->expand("Module",$m) or next; + # XXX we need available_version which reflects + # $ENV{PERL5LIB} so that already tested but not yet + # installed modules are counted. + my $available_version = $m_obj->available_version; + my $available_file = $m_obj->available_file; + if ($available_version && + !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m}) + ) { + CPAN->debug("m[$m] good enough available_version[$available_version]") + if $CPAN::DEBUG; + } elsif ($available_file + && ( + !$self->{prereq_pm}{$m} + || + $self->{prereq_pm}{$m} == 0 + ) + ) { + # lex Class::Accessor::Chained::Fast which has no $VERSION + CPAN->debug("m[$m] have available_file[$available_file]") + if $CPAN::DEBUG; + } else { + push @prereq, $m; + } + } + if (@prereq) { + my $cnt = @prereq; + my $which = join ",", @prereq; + my $but = $cnt == 1 ? "one dependency not OK ($which)" : + "$cnt dependencies missing ($which)"; + $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); + $self->{make_test} = CPAN::Distrostatus->new("NO $but"); + $self->store_persistent_state; + return $self->goodbye("[dependencies] -- NA"); + } + } + + $CPAN::Frontend->myprint(" $system -- OK\n"); + $self->{make_test} = CPAN::Distrostatus->new("YES"); + $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); + # probably impossible to need the next line because badtestcnt + # has a lifespan of one command + delete $self->{badtestcnt}; + } else { + $self->{make_test} = CPAN::Distrostatus->new("NO"); + $self->{badtestcnt}++; + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + CPAN::Shell->optprint + ("hint", + sprintf + ("//hint// to see the cpan-testers results for installing this module, try: + reports %s\n", + $self->pretty_id)); + } + $self->store_persistent_state; +} + +sub _prefs_with_expect { + my($self,$where) = @_; + return unless my $prefs = $self->prefs; + return unless my $where_prefs = $prefs->{$where}; + if ($where_prefs->{expect}) { + return { + mode => "deterministic", + timeout => 15, + talk => $where_prefs->{expect}, + }; + } elsif ($where_prefs->{"eexpect"}) { + return $where_prefs->{"eexpect"}; + } + return; +} + +#-> sub CPAN::Distribution::clean ; +sub clean { + my($self) = @_; + my $make = $self->{modulebuild} ? "Build" : "make"; + $CPAN::Frontend->myprint("Running $make clean\n"); + unless (exists $self->{archived}) { + $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped". + "/untarred, nothing done\n"); + return 1; + } + unless (exists $self->{build_dir}) { + $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n"); + return 1; + } + if (exists $self->{writemakefile} + and $self->{writemakefile}->failed + ) { + $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n"); + return 1; + } + EXCUSE: { + my @e; + exists $self->{make_clean} and $self->{make_clean} eq "YES" and + push @e, "make clean already called once"; + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + } + chdir $self->{build_dir} or + Carp::confess("Couldn't chdir to $self->{build_dir}: $!"); + $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + Mac::BuildTools::make_clean($self); + return; + } + + my $system; + if ($self->{modulebuild}) { + unless (-f "Build") { + my $cwd = CPAN::anycwd(); + $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}". + " in cwd[$cwd]. Danger, Will Robinson!"); + $CPAN::Frontend->mysleep(5); + } + $system = sprintf "%s clean", $self->_build_command(); + } else { + $system = join " ", $self->_make_command(), "clean"; + } + my $system_ok = system($system) == 0; + $self->introduce_myself; + if ( $system_ok ) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + + # $self->force; + + # Jost Krieger pointed out that this "force" was wrong because + # it has the effect that the next "install" on this distribution + # will untar everything again. Instead we should bring the + # object's state back to where it is after untarring. + + for my $k (qw( + force_update + install + writemakefile + make + make_test + )) { + delete $self->{$k}; + } + $self->{make_clean} = CPAN::Distrostatus->new("YES"); + + } else { + # Hmmm, what to do if make clean failed? + + $self->{make_clean} = CPAN::Distrostatus->new("NO"); + $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n}); + + # 2006-02-27: seems silly to me to force a make now + # $self->force("make"); # so that this directory won't be used again + + } + $self->store_persistent_state; +} + +#-> sub CPAN::Distribution::goto ; +sub goto { + my($self,$goto) = @_; + $goto = $self->normalize($goto); + my $why = sprintf( + "Goto '$goto' via prefs file '%s' doc %d", + $self->{prefs_file}, + $self->{prefs_file_doc}, + ); + $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); + # 2007-07-16 akoenig : Better than NA would be if we could inherit + # the status of the $goto distro but given the exceptional nature + # of 'goto' I feel reluctant to implement it + my $goodbye_message = "[goto] -- NA $why"; + $self->goodbye($goodbye_message); + + # inject into the queue + + CPAN::Queue->delete($self->id); + CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}}); + + # and run where we left off + + my($method) = (caller(1))[3]; + CPAN->instance("CPAN::Distribution",$goto)->$method(); + CPAN::Queue->delete_first($goto); +} + +#-> sub CPAN::Distribution::install ; +sub install { + my($self) = @_; + if (my $goto = $self->prefs->{goto}) { + return $self->goto($goto); + } + unless ($self->{badtestcnt}) { + $self->test; + } + if ($CPAN::Signal) { + delete $self->{force_update}; + return; + } + my $make = $self->{modulebuild} ? "Build" : "make"; + $CPAN::Frontend->myprint("Running $make install\n"); + EXCUSE: { + my @e; + if ($self->{make} or $self->{later}) { + # go ahead + } else { + push @e, + "Make had some problems, won't install"; + } + + exists $self->{make} and + ( + UNIVERSAL::can($self->{make},"failed") ? + $self->{make}->failed : + $self->{make} =~ /^NO/ + ) and + push @e, "Make had returned bad status, install seems impossible"; + + if (exists $self->{build_dir}) { + } elsif (!@e) { + push @e, "Has no own directory"; + } + + if (exists $self->{make_test} and + ( + UNIVERSAL::can($self->{make_test},"failed") ? + $self->{make_test}->failed : + $self->{make_test} =~ /^NO/ + )) { + if ($self->{force_update}) { + $self->{make_test}->text("FAILED but failure ignored because ". + "'force' in effect"); + } else { + push @e, "make test had returned bad status, ". + "won't install without force" + } + } + if (exists $self->{install}) { + if (UNIVERSAL::can($self->{install},"text") ? + $self->{install}->text eq "YES" : + $self->{install} =~ /^YES/ + ) { + $CPAN::Frontend->myprint(" Already done\n"); + $CPAN::META->is_installed($self->{build_dir}); + return 1; + } else { + # comment in Todo on 2006-02-11; maybe retry? + push @e, "Already tried without success"; + } + } + + push @e, $self->{later} if $self->{later}; + push @e, $self->{configure_requires_later} if $self->{configure_requires_later}; + + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; + unless (chdir $self->{build_dir}) { + push @e, "Couldn't chdir to '$self->{build_dir}': $!"; + } + $CPAN::Frontend->mywarn(join "", map {" $_\n"} @e) and return if @e; + } + $self->debug("Changed directory to $self->{build_dir}") + if $CPAN::DEBUG; + + if ($^O eq 'MacOS') { + Mac::BuildTools::make_install($self); + return; + } + + my $system; + if (my $commandline = $self->prefs->{install}{commandline}) { + $system = $commandline; + $ENV{PERL} = CPAN::find_perl(); + } elsif ($self->{modulebuild}) { + my($mbuild_install_build_command) = + exists $CPAN::HandleConfig::keys{mbuild_install_build_command} && + $CPAN::Config->{mbuild_install_build_command} ? + $CPAN::Config->{mbuild_install_build_command} : + $self->_build_command(); + $system = sprintf("%s install %s", + $mbuild_install_build_command, + $CPAN::Config->{mbuild_install_arg}, + ); + } else { + my($make_install_make_command) = + CPAN::HandleConfig->prefs_lookup($self, + q{make_install_make_command}) + || $self->_make_command(); + $system = sprintf("%s install %s", + $make_install_make_command, + $CPAN::Config->{make_install_arg}, + ); + } + + my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 "; + my $brip = CPAN::HandleConfig->prefs_lookup($self, + q{build_requires_install_policy}); + $brip ||="ask/yes"; + my $id = $self->id; + my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command + my $want_install = "yes"; + if ($reqtype eq "b") { + if ($brip eq "no") { + $want_install = "no"; + } elsif ($brip =~ m|^ask/(.+)|) { + my $default = $1; + $default = "yes" unless $default =~ /^(y|n)/i; + $want_install = + CPAN::Shell::colorable_makemaker_prompt + ("$id is just needed temporarily during building or testing. ". + "Do you want to install it permanently?", + $default); + } + } + unless ($want_install =~ /^y/i) { + my $is_only = "is only 'build_requires'"; + $CPAN::Frontend->mywarn("Not installing because $is_only\n"); + $self->{install} = CPAN::Distrostatus->new("NO -- $is_only"); + delete $self->{force_update}; + return; + } + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) + ? $ENV{PERL5LIB} + : ($ENV{PERLLIB} || ""); + + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; + $CPAN::META->set_perl5lib; + my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak +("Can't execute $system: $!"); + my($makeout) = ""; + while (<$pipe>) { + print $_; # intentionally NOT use Frontend->myprint because it + # looks irritating when we markup in color what we + # just pass through from an external program + $makeout .= $_; + } + $pipe->close; + my $close_ok = $? == 0; + $self->introduce_myself; + if ( $close_ok ) { + $CPAN::Frontend->myprint(" $system -- OK\n"); + $CPAN::META->is_installed($self->{build_dir}); + $self->{install} = CPAN::Distrostatus->new("YES"); + } else { + $self->{install} = CPAN::Distrostatus->new("NO"); + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + my $mimc = + CPAN::HandleConfig->prefs_lookup($self, + q{make_install_make_command}); + if ( + $makeout =~ /permission/s + && $> > 0 + && ( + ! $mimc + || $mimc eq (CPAN::HandleConfig->prefs_lookup($self, + q{make})) + ) + ) { + $CPAN::Frontend->myprint( + qq{----\n}. + qq{ You may have to su }. + qq{to root to install the package\n}. + qq{ (Or you may want to run something like\n}. + qq{ o conf make_install_make_command 'sudo make'\n}. + qq{ to raise your permissions.} + ); + } + } + delete $self->{force_update}; + $self->store_persistent_state; +} + +sub introduce_myself { + my($self) = @_; + $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); +} + +#-> sub CPAN::Distribution::dir ; +sub dir { + shift->{build_dir}; +} + +#-> sub CPAN::Distribution::perldoc ; +sub perldoc { + my($self) = @_; + + my($dist) = $self->id; + my $package = $self->called_for; + + if ($CPAN::META->has_inst("Pod::Perldocs")) { + my($perl) = $self->perl + or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); + my @args = ($perl, q{-MPod::Perldocs}, q{-e}, + q{Pod::Perldocs->run()}, $package); + my($wstatus); + unless ( ($wstatus = system(@args)) == 0 ) { + my $estatus = $wstatus >> 8; + $CPAN::Frontend->myprint(qq{ + Function system("@args") + returned status $estatus (wstat $wstatus) + }); + } + } + else { + $self->_display_url( $CPAN::Defaultdocs . $package ); + } +} + +#-> sub CPAN::Distribution::_check_binary ; +sub _check_binary { + my ($dist,$shell,$binary) = @_; + my ($pid,$out); + + $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n}) + if $CPAN::DEBUG; + + if ($CPAN::META->has_inst("File::Which")) { + return File::Which::which($binary); + } else { + local *README; + $pid = open README, "which $binary|" + or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n}); + return unless $pid; + while (<README>) { + $out .= $_; + } + close README + or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n") + and return; + } + + $CPAN::Frontend->myprint(qq{ + $out \n}) + if $CPAN::DEBUG && $out; + + return $out; +} + +#-> sub CPAN::Distribution::_display_url ; +sub _display_url { + my($self,$url) = @_; + my($res,$saved_file,$pid,$out); + + $CPAN::Frontend->myprint(qq{ + _display_url($url)\n}) + if $CPAN::DEBUG; + + # should we define it in the config instead? + my $html_converter = "html2text.pl"; + + my $web_browser = $CPAN::Config->{'lynx'} || undef; + my $web_browser_out = $web_browser + ? CPAN::Distribution->_check_binary($self,$web_browser) + : undef; + + if ($web_browser_out) { + # web browser found, run the action + my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'}); + $CPAN::Frontend->myprint(qq{system[$browser $url]}) + if $CPAN::DEBUG; + $CPAN::Frontend->myprint(qq{ +Displaying URL + $url +with browser $browser +}); + $CPAN::Frontend->mysleep(1); + system("$browser $url"); + if ($saved_file) { 1 while unlink($saved_file) } + } else { + # web browser not found, let's try text only + my $html_converter_out = + CPAN::Distribution->_check_binary($self,$html_converter); + $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out); + + if ($html_converter_out ) { + # html2text found, run it + $saved_file = CPAN::Distribution->_getsave_url( $self, $url ); + $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n}) + unless defined($saved_file); + + local *README; + $pid = open README, "$html_converter $saved_file |" + or $CPAN::Frontend->mydie(qq{ +Could not fork '$html_converter $saved_file': $!}); + my($fh,$filename); + if ($CPAN::META->has_usable("File::Temp")) { + $fh = File::Temp->new( + dir => File::Spec->tmpdir, + template => 'cpan_htmlconvert_XXXX', + suffix => '.txt', + unlink => 0, + ); + $filename = $fh->filename; + } else { + $filename = "cpan_htmlconvert_$$.txt"; + $fh = FileHandle->new(); + open $fh, ">$filename" or die; + } + while (<README>) { + $fh->print($_); + } + close README or + $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!}); + my $tmpin = $fh->filename; + $CPAN::Frontend->myprint(sprintf(qq{ +Run '%s %s' and +saved output to %s\n}, + $html_converter, + $saved_file, + $tmpin, + )) if $CPAN::DEBUG; + close $fh; + local *FH; + open FH, $tmpin + or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!}); + my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; + my $pager = $CPAN::Config->{'pager'} || "cat"; + $fh_pager->open("|$pager") + or $CPAN::Frontend->mydie(qq{ +Could not open pager '$pager': $!}); + $CPAN::Frontend->myprint(qq{ +Displaying URL + $url +with pager "$pager" +}); + $CPAN::Frontend->mysleep(1); + $fh_pager->print(<FH>); + $fh_pager->close; + } else { + # coldn't find the web browser or html converter + $CPAN::Frontend->myprint(qq{ +You need to install lynx or $html_converter to use this feature.}); + } + } +} + +#-> sub CPAN::Distribution::_getsave_url ; +sub _getsave_url { + my($dist, $shell, $url) = @_; + + $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n}) + if $CPAN::DEBUG; + + my($fh,$filename); + if ($CPAN::META->has_usable("File::Temp")) { + $fh = File::Temp->new( + dir => File::Spec->tmpdir, + template => "cpan_getsave_url_XXXX", + suffix => ".html", + unlink => 0, + ); + $filename = $fh->filename; + } else { + $fh = FileHandle->new; + $filename = "cpan_getsave_url_$$.html"; + } + my $tmpin = $filename; + if ($CPAN::META->has_usable('LWP')) { + $CPAN::Frontend->myprint("Fetching with LWP: + $url +"); + my $Ua; + CPAN::LWP::UserAgent->config; + eval { $Ua = CPAN::LWP::UserAgent->new; }; + if ($@) { + $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n"); + return; + } else { + my($var); + $Ua->proxy('http', $var) + if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; + $Ua->no_proxy($var) + if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; + } + + my $req = HTTP::Request->new(GET => $url); + $req->header('Accept' => 'text/html'); + my $res = $Ua->request($req); + if ($res->is_success) { + $CPAN::Frontend->myprint(" + request successful.\n") + if $CPAN::DEBUG; + print $fh $res->content; + close $fh; + $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n}) + if $CPAN::DEBUG; + return $tmpin; + } else { + $CPAN::Frontend->myprint(sprintf( + "LWP failed with code[%s], message[%s]\n", + $res->code, + $res->message, + )); + return; + } + } else { + $CPAN::Frontend->mywarn(" LWP not available\n"); + return; + } +} + +#-> sub CPAN::Distribution::_build_command +sub _build_command { + my($self) = @_; + if ($^O eq "MSWin32") { # special code needed at least up to + # Module::Build 0.2611 and 0.2706; a fix + # in M:B has been promised 2006-01-30 + my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); + return "$perl ./Build"; + } + return "./Build"; +} + +#-> sub CPAN::Distribution::_should_report +sub _should_report { + my($self, $phase) = @_; + die "_should_report() requires a 'phase' argument" + if ! defined $phase; + + # configured + my $test_report = CPAN::HandleConfig->prefs_lookup($self, + q{test_report}); + return unless $test_report; + + # don't repeat if we cached a result + return $self->{should_report} + if exists $self->{should_report}; + + # don't report if we generated a Makefile.PL + if ( $self->{had_no_makefile_pl} ) { + $CPAN::Frontend->mywarn( + "Will not send CPAN Testers report with generated Makefile.PL.\n" + ); + return $self->{should_report} = 0; + } + + # available + if ( ! $CPAN::META->has_inst("CPAN::Reporter")) { + $CPAN::Frontend->mywarn( + "CPAN::Reporter not installed. No reports will be sent.\n" + ); + return $self->{should_report} = 0; + } + + # capable + my $crv = CPAN::Reporter->VERSION; + if ( CPAN::Version->vlt( $crv, 0.99 ) ) { + # don't cache $self->{should_report} -- need to check each phase + if ( $phase eq 'test' ) { + return 1; + } + else { + $CPAN::Frontend->mywarn( + "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" . + "you only have version $crv\. Only 'test' phase reports will be sent.\n" + ); + return; + } + } + + # appropriate + if ($self->is_dot_dist) { + $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". + "for local directories\n"); + return $self->{should_report} = 0; + } + if ($self->prefs->{patches} + && + @{$self->prefs->{patches}} + && + $self->{patched} + ) { + $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ". + "when the source has been patched\n"); + return $self->{should_report} = 0; + } + + # proceed and cache success + return $self->{should_report} = 1; +} + +#-> sub CPAN::Distribution::reports +sub reports { + my($self) = @_; + my $pathname = $self->id; + $CPAN::Frontend->myprint("Distribution: $pathname\n"); + + unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) { + $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue"); + } + unless ($CPAN::META->has_usable("LWP")) { + $CPAN::Frontend->mydie("LWP not installed; cannot continue"); + } + unless ($CPAN::META->has_usable("File::Temp")) { + $CPAN::Frontend->mydie("File::Temp not installed; cannot continue"); + } + + my $d = CPAN::DistnameInfo->new($pathname); + + my $dist = $d->dist; # "CPAN-DistnameInfo" + my $version = $d->version; # "0.02" + my $maturity = $d->maturity; # "released" + my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" + my $cpanid = $d->cpanid; # "GBARR" + my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" + + my $url = sprintf "http://www.cpantesters.org/show/%s.yaml", $dist; + + CPAN::LWP::UserAgent->config; + my $Ua; + eval { $Ua = CPAN::LWP::UserAgent->new; }; + if ($@) { + $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n"); + } + $CPAN::Frontend->myprint("Fetching '$url'..."); + my $resp = $Ua->get($url); + unless ($resp->is_success) { + $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code); + } + $CPAN::Frontend->myprint("DONE\n\n"); + my $yaml = $resp->content; + # was fuer ein Umweg! + my $fh = File::Temp->new( + dir => File::Spec->tmpdir, + template => 'cpan_reports_XXXX', + suffix => '.yaml', + unlink => 0, + ); + my $tfilename = $fh->filename; + print $fh $yaml; + close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!"); + my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0]; + unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!"); + my %other_versions; + my $this_version_seen; + for my $rep (@$unserialized) { + my $rversion = $rep->{version}; + if ($rversion eq $version) { + unless ($this_version_seen++) { + $CPAN::Frontend->myprint ("$rep->{version}:\n"); + } + my $arch = $rep->{archname} || $rep->{platform} || '????'; + my $grade = $rep->{action} || $rep->{status} || '????'; + my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????'; + $CPAN::Frontend->myprint + (sprintf("%1s%1s%-4s %s on %s %s (%s)\n", + $arch eq $Config::Config{archname}?"*":"", + $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"", + $grade, + $rep->{perl}, + $ostext, + $rep->{osvers}, + $arch, + )); + } else { + $other_versions{$rep->{version}}++; + } + } + unless ($this_version_seen) { + $CPAN::Frontend->myprint("No reports found for version '$version' +Reports for other versions:\n"); + for my $v (sort keys %other_versions) { + $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n"); + } + } + $url =~ s/\.yaml/.html/; + $CPAN::Frontend->myprint("See $url for details\n"); +} + +1; |