From: Steve Peters Date: Wed, 29 Oct 2008 19:21:49 +0000 (+0000) Subject: Upgrade to CPAN-1.9301. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5254b38efe447cab6b380b613825d484abf7a3f2;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CPAN-1.9301. p4raw-id: //depot/perl@34638 --- diff --git a/MANIFEST b/MANIFEST index 224474c..2992de2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1786,10 +1786,11 @@ lib/Config.t See if Config works lib/constant.pm For "use constant" lib/constant.t See if compile-time constants work lib/CORE.pod document the CORE namespace -lib/CPAN/API/HOWTO.pm recipe book for programming with CPAN.pm +lib/CPAN/API/HOWTO.pod recipe book for programming with CPAN.pm lib/CPAN/bin/cpan easily interact with CPAN from the command line lib/CPAN/Debug.pm helper package for CPAN.pm lib/CPAN/DeferedCode.pm helper package for CPAN.pm +lib/CPAN/Distroprefs.pm helper package for CPAN.pm lib/CPAN/FirstTime.pm Utility for creating CPAN config files lib/CPAN/HandleConfig.pm helper package for CPAN.pm lib/CPAN/Kwalify/distroprefs.dd helper file for validating config files diff --git a/lib/CPAN.pm b/lib/CPAN.pm index edb8541..fa3f920 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,9 +1,20 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '1.9205'; -$CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/; +$CPAN::VERSION = '1.9301'; +$CPAN::VERSION =~ s/_//; +# we need to run chdir all over and we would get at wrong libraries +# there +use File::Spec (); +BEGIN { + if (File::Spec->can("rel2abs")) { + for my $inc (@INC) { + $inc = File::Spec->rel2abs($inc) unless ref $inc; + } + } +} use CPAN::HandleConfig; use CPAN::Version; use CPAN::Debug; @@ -12,7 +23,7 @@ use CPAN::Tarzip; use CPAN::DeferedCode; use Carp (); use Config (); -use Cwd (); +use Cwd qw(chdir); use DirHandle (); use Exporter (); use ExtUtils::MakeMaker qw(prompt); # for some unknown reason, @@ -22,7 +33,6 @@ use File::Basename (); use File::Copy (); use File::Find; use File::Path (); -use File::Spec (); use FileHandle (); use Fcntl qw(:flock); use Safe (); @@ -30,20 +40,42 @@ use Sys::Hostname qw(hostname); use Text::ParseWords (); use Text::Wrap (); +# protect against "called too early" sub find_perl (); +sub anycwd (); -# we need to run chdir all over and we would get at wrong libraries -# there -BEGIN { - if (File::Spec->can("rel2abs")) { - for my $inc (@INC) { - $inc = File::Spec->rel2abs($inc) unless ref $inc; - } - } -} no lib "."; require Mac::BuildTools if $^O eq 'MacOS'; +if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) { + $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING}; + my $rec = $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} .= ",$$"; + my @rec = split /,/, $rec; + # warn "# Note: Recursive call of CPAN.pm detected\n"; + my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec; + my %sleep = ( + 5 => 30, + 6 => 60, + 7 => 120, + ); + my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0); + my $verbose = @rec >= 4; + while (@rec) { + $w .= sprintf " which has been called by process %d", pop @rec; + } + if ($sleep) { + $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n"; + } + if ($verbose) { + warn $w; + } + local $| = 1; + while ($sleep > 0) { + printf "\r#%5d", --$sleep; + sleep 1; + } + print "\n"; +} $ENV{PERL5_CPAN_IS_RUNNING}=$$; $ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735 @@ -58,7 +90,8 @@ unless (@CPAN::Defaultsites) { "http://www.perl.org/CPAN/", "ftp://ftp.perl.org/pub/CPAN/"; } -# $CPAN::iCwd (i for initial) is going to be initialized during find_perl +# $CPAN::iCwd (i for initial) +$CPAN::iCwd ||= CPAN::anycwd(); $CPAN::Perl ||= CPAN::find_perl(); $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; $CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf"; @@ -154,6 +187,46 @@ sub soft_chdir_with_alternatives ($); } } +{ + my $x = *SAVEOUT; # avoid warning + open($x,">&STDOUT") or die "dup failed"; + my $redir = 0; + sub _redirect(@) { + #die if $redir; + local $_; + push(@_,undef); + while(defined($_=shift)) { + if (s/^\s*>//){ + my ($m) = s/^>// ? ">" : ""; + s/\s+//; + $_=shift unless length; + die "no dest" unless defined; + open(STDOUT,">$m$_") or die "open:$_:$!\n"; + $redir=1; + } elsif ( s/^\s*\|\s*// ) { + my $pipe="| $_"; + while(defined($_[0])){ + $pipe .= ' ' . shift; + } + open(STDOUT,$pipe) or die "open:$pipe:$!\n"; + $redir=1; + } else { + push(@_,$_); + } + } + return @_; + } + sub _unredirect { + return unless $redir; + $redir = 0; + ## redirect: unredirect and propagate errors. explicit close to wait for pipe. + close(STDOUT); + open(STDOUT,">&SAVEOUT"); + die "$@" if "$@"; + ## redirect: done + } +} + #-> sub CPAN::shell ; sub shell { my($self) = @_; @@ -271,13 +344,18 @@ ReadLine support %s next SHELLCOMMAND unless @line; $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; my $command = shift @line; - eval { CPAN::Shell->$command(@line) }; + eval { + local (*STDOUT)=*STDOUT; + @line = _redirect(@line); + CPAN::Shell->$command(@line) + }; + _unredirect; if ($@) { my $err = "$@"; if ($err =~ /\S/) { require Carp; require Dumpvalue; - my $dv = Dumpvalue->new(); + my $dv = Dumpvalue->new(tick => '"'); Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err)); } } @@ -387,10 +465,10 @@ Trying to chdir to "$cwd->[1]" instead. sub _flock { my($fh,$mode) = @_; - if ($Config::Config{d_flock}) { + if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) { return flock $fh, $mode; } elsif (!$Have_warned->{"d_flock"}++) { - $CPAN::Frontend->mywarn("Your OS does not support locking; continuing and ignoring all locking issues\n"); + $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n"); $CPAN::Frontend->mysleep(5); return 1; } else { @@ -433,32 +511,30 @@ sub _yaml_loadfile { # temporarly enable yaml code deserialisation no strict 'refs'; # 5.6.2 could not do the local() with the reference - local $YAML::LoadCode; - local $YAML::Syck::LoadCode; + # so we do it manually instead + my $old_loadcode = ${"$yaml_module\::LoadCode"}; ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0; - my $code; + my ($code, @yaml); if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) { - my @yaml; eval { @yaml = $code->($local_file); }; if ($@) { # this shall not be done by the frontend die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); } - return \@yaml; } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { local *FH; open FH, $local_file or die "Could not open '$local_file': $!"; local $/; my $ystream = ; - my @yaml; eval { @yaml = $code->($ystream); }; if ($@) { # this shall not be done by the frontend die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); } - return \@yaml; } + ${"$yaml_module\::LoadCode"} = $old_loadcode; + return \@yaml; } else { # this shall not be done by the frontend die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); @@ -523,6 +599,7 @@ sub _init_sqlite () { package CPAN::CacheMgr; use strict; @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN); +use Cwd qw(chdir); use File::Find; package CPAN::FTP; @@ -696,10 +773,13 @@ use overload '""' => "as_string"; sub new { my($class,$module,$file,$during,$error) = @_; + # my $at = Carp::longmess(""); # XXX find something more beautiful bless { module => $module, file => $file, during => $during, - error => $error }, $class; + error => $error, + # at => $at, + }, $class; } sub as_string { @@ -774,15 +854,24 @@ sub text { package CPAN::Distrostatus; use overload '""' => "as_string", fallback => 1; +use vars qw($something_has_failed_at); sub new { my($class,$arg) = @_; + my $failed = substr($arg,0,2) eq "NO"; + if ($failed) { + $something_has_failed_at = $CPAN::CurrentCommandId; + } bless { TEXT => $arg, - FAILED => substr($arg,0,2) eq "NO", + FAILED => $failed, COMMANDID => $CPAN::CurrentCommandId, TIME => time, }, $class; } +sub something_has_just_failed () { + defined $something_has_failed_at && + $something_has_failed_at == $CPAN::CurrentCommandId; +} sub commandid { shift->{COMMANDID} } sub failed { shift->{FAILED} } sub text { @@ -807,8 +896,28 @@ use vars qw( $autoload_recursion $reload @ISA + @relo ); +@relo = ( + "CPAN.pm", + "CPAN/Debug.pm", + "CPAN/Distroprefs.pm", + "CPAN/FirstTime.pm", + "CPAN/HandleConfig.pm", + "CPAN/Kwalify.pm", + "CPAN/Queue.pm", + "CPAN/Reporter/Config.pm", + "CPAN/Reporter/History.pm", + "CPAN/Reporter/PrereqCheck.pm", + "CPAN/Reporter.pm", + "CPAN/SQLite.pm", + "CPAN/Tarzip.pm", + "CPAN/Version.pm", + ); +# record the initial timestamp for reload. +$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo }; @CPAN::Shell::ISA = qw(CPAN::Debug); +use Cwd qw(chdir); $COLOR_REGISTERED ||= 0; $Help = { '?' => \"help", @@ -995,7 +1104,7 @@ sub checklock { qq{ There seems to be running another CPAN process (pid $otherpid). Contacting... }); - if (kill 0, $otherpid) { + if (kill 0, $otherpid or $!{EPERM}) { $CPAN::Frontend->mywarn(qq{Other job is running.\n}); my($ans) = CPAN::Shell::colorable_makemaker_prompt @@ -1189,10 +1298,10 @@ sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd} #-> sub CPAN::find_perl ; sub find_perl () { my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : ""; - my $pwd = $CPAN::iCwd = CPAN::anycwd(); - my $candidate = File::Spec->catfile($pwd,$^X); - $perl ||= $candidate if MM->maybe_command($candidate); - + unless ($perl) { + my $candidate = File::Spec->catfile($CPAN::iCwd,$^X); + $^X = $perl = $candidate if MM->maybe_command($candidate); + } unless ($perl) { my ($component,$perl_name); DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") { @@ -1201,13 +1310,12 @@ sub find_perl () { next unless defined($component) && $component; my($abs) = File::Spec->catfile($component,$perl_name); if (MM->maybe_command($abs)) { - $perl = $abs; + $^X = $perl = $abs; last DIST_PERLNAME; } } } } - return $perl; } @@ -1446,8 +1554,10 @@ sub cleanup { #-> sub CPAN::readhist sub readhist { my($self,$term,$histfile) = @_; + my $histsize = $CPAN::Config->{'histsize'} || 100; + $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'})); my($fh) = FileHandle->new; - open $fh, "<$histfile" or last; + open $fh, "<$histfile" or return; local $/ = "\n"; while (<$fh>) { chomp; @@ -1492,6 +1602,13 @@ sub is_tested { $self->{is_tested}{$what} = $when; } +#-> sub CPAN::reset_tested +# forget all distributions tested -- resets what gets included in PERL5LIB +sub reset_tested { + my ($self) = @_; + $self->{is_tested} = {}; +} + #-> sub CPAN::is_installed # unsets the is_tested flag: as soon as the thing is installed, it is # not needed in set_perl5lib anymore @@ -1508,6 +1625,10 @@ sub _list_sorted_descending_is_tested { } #-> sub CPAN::set_perl5lib +# Notes on max environment variable length: +# - Win32 : XP or later, 8191; Win2000 or NT4, 2047 +{ +my $fh; sub set_perl5lib { my($self,$for) = @_; unless ($for) { @@ -1519,32 +1640,35 @@ sub set_perl5lib { my $env = $ENV{PERL5LIB}; $env = $ENV{PERLLIB} unless defined $env; my @env; - push @env, $env if defined $env and length $env; + push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env; #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; + return if !@dirs; + if (@dirs < 12) { - $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n"); - } elsif (@dirs < 24) { + $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n"); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + } elsif (@dirs < 24 ) { my @d = map {my $cp = $_; $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; $cp } @dirs; - $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ". + $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ". "%BUILDDIR%=$CPAN::Config->{build_dir} ". "for '$for'\n" ); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; } else { my $cnt = keys %{$self->{is_tested}}; - $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ". + $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ". "$cnt build dirs to PERL5LIB; ". "for '$for'\n" ); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; } - - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; -} +}} package CPAN::CacheMgr; use strict; @@ -2188,6 +2312,7 @@ sub hosts { $CPAN::Frontend->myprint($R); } +# here is where 'reload cpan' is done #-> sub CPAN::Shell::reload ; sub reload { my($self,$command,@arg) = @_; @@ -2197,20 +2322,6 @@ sub reload { my $redef = 0; chdir $CPAN::iCwd if $CPAN::iCwd; # may fail my $failed; - my @relo = ( - "CPAN.pm", - "CPAN/Debug.pm", - "CPAN/FirstTime.pm", - "CPAN/HandleConfig.pm", - "CPAN/Kwalify.pm", - "CPAN/Queue.pm", - "CPAN/Reporter/Config.pm", - "CPAN/Reporter/History.pm", - "CPAN/Reporter.pm", - "CPAN/SQLite.pm", - "CPAN/Tarzip.pm", - "CPAN/Version.pm", - ); MFILE: for my $f (@relo) { next unless exists $INC{$f}; my $p = $f; @@ -2269,13 +2380,7 @@ sub _reload_this { return; } my $mtime = (stat $file)[9]; - if ($reload->{$f}) { - } elsif ($^T < $mtime) { - # since we started the file has changed, force it to be reloaded - $reload->{$f} = -1; - } else { - $reload->{$f} = $mtime; - } + $reload->{$f} ||= -1; my $must_reload = $mtime != $reload->{$f}; $args ||= {}; $must_reload ||= $args->{reloforce}; # o conf defaults needs this @@ -2514,47 +2619,90 @@ sub _u_r_common { $version_undefs = $version_zeroes = 0; my $sprintf = "%s%-25s%s %9s %9s %s\n"; my @expand = $self->expand('Module',@args); - my $expand = scalar @expand; - if (0) { # Looks like noise to me, was very useful for debugging + if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging # for metadata cache - $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand); - } - MODULE: for $module (@expand) { + my $expand = scalar @expand; + $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time); + } + my @sexpand; + if ($] < 5.008) { + # hard to believe that the more complex sorting can lead to + # stack curruptions on older perl + @sexpand = sort {$a->id cmp $b->id} @expand; + } else { + @sexpand = map { + $_->[1] + } sort { + $b->[0] <=> $a->[0] + || + $a->[1]{ID} cmp $b->[1]{ID}, + } map { + [$_->_is_representative_module, + $_ + ] + } @expand; + } + if ($CPAN::DEBUG) { + $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time); + sleep 1; + } + MODULE: for $module (@sexpand) { my $file = $module->cpan_file; next MODULE unless defined $file; # ?? $file =~ s!^./../!!; my($latest) = $module->cpan_version; my($inst_file) = $module->inst_file; + CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG; my($have); return if $CPAN::Signal; - if ($inst_file) { - if ($what eq "a") { - $have = $module->inst_version; - } elsif ($what eq "r") { - $have = $module->inst_version; - local($^W) = 0; - if ($have eq "undef") { - $version_undefs++; - push @version_undefs, $module->as_glimpse; - } elsif (CPAN::Version->vcmp($have,0)==0) { - $version_zeroes++; - push @version_zeroes, $module->as_glimpse; + my($next_MODULE); + eval { # version.pm involved! + if ($inst_file) { + if ($what eq "a") { + $have = $module->inst_version; + } elsif ($what eq "r") { + $have = $module->inst_version; + local($^W) = 0; + if ($have eq "undef") { + $version_undefs++; + push @version_undefs, $module->as_glimpse; + } elsif (CPAN::Version->vcmp($have,0)==0) { + $version_zeroes++; + push @version_zeroes, $module->as_glimpse; + } + ++$next_MODULE unless CPAN::Version->vgt($latest, $have); + # to be pedantic we should probably say: + # && !($have eq "undef" && $latest ne "undef" && $latest gt ""); + # to catch the case where CPAN has a version 0 and we have a version undef + } elsif ($what eq "u") { + ++$next_MODULE; + } + } else { + if ($what eq "a") { + ++$next_MODULE; + } elsif ($what eq "r") { + ++$next_MODULE; + } elsif ($what eq "u") { + $have = "-"; } - next MODULE unless CPAN::Version->vgt($latest, $have); -# to be pedantic we should probably say: -# && !($have eq "undef" && $latest ne "undef" && $latest gt ""); -# to catch the case where CPAN has a version 0 and we have a version undef - } elsif ($what eq "u") { - next MODULE; - } - } else { - if ($what eq "a") { - next MODULE; - } elsif ($what eq "r") { - next MODULE; - } elsif ($what eq "u") { - $have = "-"; } + }; + next MODULE if $next_MODULE; + if ($@) { + $CPAN::Frontend->mywarn + (sprintf("Error while comparing cpan/installed versions of '%s': +INST_FILE: %s +INST_VERSION: %s %s +CPAN_VERSION: %s %s +", + $module->id, + $inst_file || "", + (defined $have ? $have : "[UNDEFINED]"), + (ref $have ? ref $have : ""), + $latest, + (ref $latest ? ref $latest : ""), + )); + next MODULE; } return if $CPAN::Signal; # this is sometimes lengthy $seen{$file} ||= 0; @@ -2894,6 +3042,7 @@ sub expand_by_method { ) if $CPAN::DEBUG; if (defined $regex) { if (CPAN::_sqlite_running) { + CPAN::Index->reload; $CPAN::SQLite->search($class, $regex); } for $obj ( @@ -2965,7 +3114,9 @@ that may go away anytime.\n" if ( $CPAN::DEBUG ) { my $wantarray = wantarray; my $join_m = join ",", map {$_->id} @m; - $self->debug("wantarray[$wantarray]join_m[$join_m]"); + # $self->debug("wantarray[$wantarray]join_m[$join_m]"); + my $count = scalar @m; + $self->debug("class[$class]wantarray[$wantarray]count m[$count]"); } return wantarray ? @m : $m[0]; } @@ -3019,7 +3170,7 @@ sub format_result { # to turn colordebugging on, write # cpan> o conf colorize_output 1 -#-> sub CPAN::Shell::print_ornamented ; +#-> sub CPAN::Shell::colorize_output ; { my $print_ornamented_have_warned = 0; sub colorize_output { @@ -3064,7 +3215,7 @@ sub print_ornamented { print "Term::ANSIColor rejects color[$ornament]: $@\n Please choose a different color (Hint: try 'o conf init /color/')\n"; } - # GGOLDBACH/Test-GreaterVersion-0.008 broke wthout this + # GGOLDBACH/Test-GreaterVersion-0.008 broke without this # $trailer construct. We want the newline be the last thing if # there is a newline at the end ensuring that the next line is # empty for other players @@ -3301,7 +3452,7 @@ to find objects with matching identifiers. # queuerunner (please be warned: when I started to change the # queue to hold objects instead of names, I made one or two # mistakes and never found which. I reverted back instead) - while (my $q = CPAN::Queue->first) { + QITEM: while (my $q = CPAN::Queue->first) { my $obj; my $s = $q->as_string; my $reqtype = $q->reqtype || ""; @@ -3314,7 +3465,7 @@ to find objects with matching identifiers. "to an object. Skipping.\n"); $CPAN::Frontend->mysleep(5); CPAN::Queue->delete_first($s); - next; + next QITEM; } $obj->{reqtype} ||= ""; { @@ -3393,6 +3544,14 @@ to find objects with matching identifiers. $obj->$unpragma(); } } + if ($CPAN::Config->{halt_on_failure} + && + CPAN::Distrostatus::something_has_just_failed() + ) { + $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n"); + CPAN::Queue->nullify_queue; + last QITEM; + } CPAN::Queue->delete_first($s); } if ($meth =~ /^($needs_recursion_protection)$/) { @@ -3438,7 +3597,7 @@ sub recent { $distro =~ s|.*?/authors/id/./../||; my $size = $eitem->findvalue("enclosure/\@length"); my $desc = $eitem->findvalue("description"); - $desc =~ s/.+? - //; + $desc =~ s/.+? - //; $CPAN::Frontend->myprint("$distro [$size b]\n $desc\n"); push @distros, $distro; } @@ -3494,6 +3653,7 @@ sub smoke { my($self) = @_; my $distros = $self->recent; DISTRO: for my $distro (@$distros) { + next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles $CPAN::Frontend->myprint(sprintf "Going to download and test '$distro'\n"); { my $skip = 0; @@ -3566,10 +3726,9 @@ sub get_basic_credentials { sub get_proxy_credentials { my $self = shift; my ($user, $password); - if ( defined $CPAN::Config->{proxy_user} && - defined $CPAN::Config->{proxy_pass}) { + if ( defined $CPAN::Config->{proxy_user} ) { $user = $CPAN::Config->{proxy_user}; - $password = $CPAN::Config->{proxy_pass}; + $password = $CPAN::Config->{proxy_pass} || ""; return ($user, $password); } my $username_prompt = "\nProxy authentication needed! @@ -3585,10 +3744,9 @@ sub get_proxy_credentials { sub get_non_proxy_credentials { my $self = shift; my ($user,$password); - if ( defined $CPAN::Config->{username} && - defined $CPAN::Config->{password}) { + if ( defined $CPAN::Config->{username} ) { $user = $CPAN::Config->{username}; - $password = $CPAN::Config->{password}; + $password = $CPAN::Config->{password} || ""; return ($user, $password); } my $username_prompt = "\nAuthentication needed! @@ -3734,11 +3892,7 @@ sub _add_to_statistics { $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG; if ($CPAN::META->has_inst($yaml_module)) { $stats->{thesiteurl} = $ThesiteURL; - if (CPAN->has_inst("Time::HiRes")) { - $stats->{end} = Time::HiRes::time(); - } else { - $stats->{end} = time; - } + $stats->{end} = CPAN::FTP::_mytime(); my $fh = FileHandle->new; my $time = time; my $sdebug = 0; @@ -3750,12 +3904,13 @@ sub _add_to_statistics { push @debug, scalar @{$fullstats->{history}} if $sdebug; push @debug, time if $sdebug; push @{$fullstats->{history}}, $stats; - # arbitrary hardcoded constants until somebody demands to have - # them settable; YAML.pm 0.62 is unacceptably slow with 999; + # YAML.pm 0.62 is unacceptably slow with 999; # YAML::Syck 0.82 has no noticable performance problem with 999; + my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99; + my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14; while ( - @{$fullstats->{history}} > 99 - || $time - $fullstats->{history}[0]{start} > 14*86400 + @{$fullstats->{history}} > $ftpstats_size + || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period ) { shift @{$fullstats->{history}} } @@ -3775,11 +3930,42 @@ sub _add_to_statistics { } # Win32 cannot rename a file to an existing filename unlink($sfile) if ($^O eq 'MSWin32'); + _copy_stat($sfile, "$sfile.$$") if -e $sfile; rename "$sfile.$$", $sfile or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n"); } } +# Copy some stat information (owner, group, mode and) from one file to +# another. +# This is a utility function which might be moved to a utility repository. +#-> sub CPAN::FTP::_copy_stat +sub _copy_stat { + my($src, $dest) = @_; + my @stat = stat($src); + if (!@stat) { + $CPAN::Frontend->mywarn("Can't stat '$src': $!\n"); + return; + } + + eval { + chmod $stat[2], $dest + or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n"); + }; + warn $@ if $@; + eval { + chown $stat[4], $stat[5], $dest + or do { + my $save_err = $!; # otherwise it's lost in the get... calls + $CPAN::Frontend->mywarn("Can't chown '$dest' to " . + (getpwuid($stat[4]))[0] . "/" . + (getgrgid($stat[5]))[0] . ": $save_err\n" + ); + }; + }; + warn $@ if $@; +} + # if file is CHECKSUMS, suggest the place where we got the file to be # checked from, maybe only for young files? #-> sub CPAN::FTP::_recommend_url_for @@ -3832,7 +4018,7 @@ sub ftp_get { my($class,$host,$dir,$file,$target) = @_; $class->debug( qq[Going to fetch file [$file] from dir [$dir] - on host [$host] as local [$target]\n] + on host [$host] as local [$target]\n] ) if $CPAN::DEBUG; my $ftp = Net::FTP->new($host); unless ($ftp) { @@ -3865,8 +4051,8 @@ sub ftp_get { # If more accuracy is wanted/needed, Chris Leach sent me this patch... - # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 - # > --- /tmp/cp Wed Sep 24 13:26:40 1997 + # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997 + # > --- /tmp/cp Wed Sep 24 13:26:40 1997 # > *************** # > *** 1562,1567 **** # > --- 1562,1580 ---- @@ -4015,6 +4201,9 @@ sub localize { $CPAN::Config->{ftp_passive} : 1; my $ret; my $stats = $self->_new_stats($file); + for ($CPAN::Config->{connect_to_internet_ok}) { + $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_; + } LEVEL: for $levelno (0..$#levels) { my $level_tuple = $levels[$levelno]; my($level,$scheme,$sitetag) = @$level_tuple; @@ -4318,6 +4507,7 @@ sub hostdlhard { # Try the most capable first and leave ncftp* for last as it only # does FTP. + my $proxy_vars = $self->_proxy_vars($ro_url); DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) { my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f}); next unless defined $funkyftp; @@ -4339,6 +4529,9 @@ sub hostdlhard { $stdout_redir = ""; } elsif ($f eq 'curl') { $src_switch = ' -L -f -s -S --netrc-optional'; + if ($proxy_vars->{http_proxy}) { + $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"}; + } } if ($f eq "ncftpget") { @@ -4435,6 +4628,39 @@ No success, the file that lynx has downloaded is an empty file. } # host } +#-> CPAN::FTP::_proxy_vars +sub _proxy_vars { + my($self,$url) = @_; + my $ret = +{}; + my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'}; + if ($http_proxy) { + my($host) = $url =~ m|://([^/:]+)|; + my $want_proxy = 1; + my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || ""; + my @noproxy = split /\s*,\s*/, $noproxy; + if ($host) { + DOMAIN: for my $domain (@noproxy) { + if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent + $want_proxy = 0; + last DOMAIN; + } + } + } else { + $CPAN::Frontend->mywarn(" Could not determine host from http_proxy '$http_proxy'\n"); + } + if ($want_proxy) { + my($user, $pass) = + &CPAN::LWP::UserAgent::get_proxy_credentials(); + $ret = { + proxy_user => $user, + proxy_pass => $pass, + http_proxy => $http_proxy + }; + } + } + return $ret; +} + # package CPAN::FTP; sub hostdlhardest { my($self,$host_seq,$file,$aslocal,$stats) = @_; @@ -4938,11 +5164,21 @@ sub reanimate_build_dir { my $i = 0; my $painted = 0; my $restored = 0; - $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n"); my @candidates = map { $_->[0] } sort { $b->[1] <=> $a->[1] } map { [ $_, -M File::Spec->catfile($d,$_) ] } grep {/\.yml$/} readdir $dh; + unless (@candidates) { + $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n"); + return; + } + $CPAN::Frontend->myprint + (sprintf("Going to read %d yaml file%s from %s/\n", + scalar @candidates, + @candidates==1 ? "" : "s", + $CPAN::Config->{build_dir} + )); + my $start = CPAN::FTP::_mytime; DISTRO: for $i (0..$#candidates) { my $dirent = $candidates[$i]; my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))}; @@ -4977,22 +5213,13 @@ sub reanimate_build_dir { notest should_report sponsored_mods + prefs + negative_prefs_cache )) { delete $do->{$skipper}; } # $DB::single = 1; - if ($do->{make_test} - && $do->{build_dir} - && !(UNIVERSAL::can($do->{make_test},"failed") ? - $do->{make_test}->failed : - $do->{make_test} =~ /^YES/ - ) - && ( - !$do->{install} - || - $do->{install}->failed - ) - ) { + if ($do->tested_ok_but_not_installed) { $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME}); } $restored++; @@ -5003,11 +5230,11 @@ sub reanimate_build_dir { $painted++; } } + my $took = CPAN::FTP::_mytime - $start; $CPAN::Frontend->myprint(sprintf( - "DONE\nFound %s old build%s, restored the state of %s\n", - @candidates ? sprintf("%d",scalar @candidates) : "no", - @candidates==1 ? "" : "s", + "DONE\nRestored the state of %s (in %.4f secs)\n", $restored || "none", + $took, )); } @@ -5187,6 +5414,10 @@ happen.\a # 1.57 we assign remaining text to $comment thus allowing to # influence isa_perl my($mod,$version,$dist,$comment) = split " ", $_, 4; + unless ($mod && defined $version && $dist) { + $CPAN::Frontend->mywarn("Could not split line[$_]\n"); + next; + } my($bundle,$id,$userid); if ($mod eq 'CPAN' && @@ -5318,10 +5549,10 @@ sub rd_modlist { } push @eval2, q{CPAN::Modulelist->data;}; local($^W) = 0; - my($comp) = Safe->new("CPAN::Safe1"); + my($compmt) = Safe->new("CPAN::Safe1"); my($eval2) = join("\n", @eval2); CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG; - my $ret = $comp->reval($eval2); + my $ret = $compmt->reval($eval2); Carp::confess($@) if $@; return if $CPAN::Signal; my $i = 0; @@ -5425,6 +5656,7 @@ sub read_metadata_cache { package CPAN::InfoObj; use strict; +use Cwd qw(chdir); sub ro { my $self = shift; @@ -5784,8 +6016,8 @@ sub dir_listing { my $eval = <$fh>; $eval =~ s/\015?\012/\n/g; close $fh; - my($comp) = Safe->new(); - $cksum = $comp->reval($eval); + my($compmt) = Safe->new(); + $cksum = $compmt->reval($eval); if ($@) { rename $lc_file, "$lc_file.bad"; Carp::confess($@) if $@; @@ -5828,6 +6060,8 @@ Please file a bugreport if you need this.\n"); package CPAN::Distribution; use strict; +use Cwd qw(chdir); +use CPAN::Distroprefs; # Accessors sub cpan_comment { @@ -5892,8 +6126,7 @@ sub normalize { $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| or - $CPAN::Frontend->mywarn("Strange distribution name [$s]\n"); + $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|; CPAN->debug("s[$s]") if $CPAN::DEBUG; } $s; @@ -5963,6 +6196,25 @@ sub base_id { 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 @@ -6092,7 +6344,7 @@ sub get { 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 @@ -6100,7 +6352,7 @@ sub get { my @e; my $goodbye_message; $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG; - if ($self->prefs->{disabled}) { + if ($self->prefs->{disabled} && ! $self->{force_update}) { my $why = sprintf( "Disabled via prefs file '%s' doc %d", $self->{prefs_file}, @@ -6149,6 +6401,11 @@ sub get { $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; } @@ -6157,7 +6414,7 @@ sub get { $self->safe_chdir($sub_wd); return; } - return $self->run_MM_or_MB($local_file); + return $self->choose_MM_or_MB($local_file); } #-> CPAN::Distribution::get_file_onto_local_disk @@ -6255,6 +6512,15 @@ EOF 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 @@ -6265,8 +6531,20 @@ EOF if (@readdir == 1 && -d $readdir[0]) { $tdir_base = $readdir[0]; $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); - my $dh2 = DirHandle->new($from_dir) - or Carp::croak("Couldn't opendir $from_dir: $!"); + 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; @@ -6372,6 +6650,31 @@ sub parse_meta_yml { 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) = @_; @@ -6419,8 +6722,8 @@ sub satisfy_configure_requires { die "never reached"; } -#-> sub CPAN::Distribution::run_MM_or_MB ; -sub run_MM_or_MB { +#-> 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"); @@ -6659,6 +6962,12 @@ We\'ll try to build it with that Makefile then. } $cf =~ s|[/\\:]||g; # risk of filesystem damage $cf = "unknown" unless length($cf); + if (my $crap = $self->_contains_crap($build_dir)) { + my $why = qq{Package contains $crap; 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}); @@ -6667,8 +6976,55 @@ We\'ll try to build it with that Makefile then. # Writing our own Makefile.PL - my $script = ""; + 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_crap +sub _contains_crap { + 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) @@ -6719,34 +7075,18 @@ We\'ll try to build it with that Makefile then. } } split /\s*,\s*/, $prereq); - $script = " - EXE_FILES => ['$name'], - PREREQ_PM => { -$PREREQ_PM - }, -"; 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: $!"; } - } - - 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],$script - ); -}); - $fh->close; - } + return " + EXE_FILES => ['$name'], + PREREQ_PM => { +$PREREQ_PM + }, +"; } #-> CPAN::Distribution::_signature_business @@ -6801,7 +7141,8 @@ and run sub untar_me { my($self,$ct) = @_; $self->{archived} = "tar"; - if ($ct->untar()) { + my $result = eval { $ct->untar() }; + if ($result) { $self->{unwrapped} = CPAN::Distrostatus->new("YES"); } else { $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed"); @@ -6896,6 +7237,15 @@ Could not determine which directory to use for looking at $dist. 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"); @@ -7083,8 +7433,8 @@ sub CHECKSUM_check_file { my $eval = <$fh>; $eval =~ s/\015?\012/\n/g; close $fh; - my($comp) = Safe->new(); - $cksum = $comp->reval($eval); + my($compmt) = Safe->new(); + $cksum = $compmt->reval($eval); if ($@) { rename $chk_file, "$chk_file.bad"; Carp::confess($@) if $@; @@ -7374,12 +7724,14 @@ is part of the perl-%s distribution. To install that, you need to run } $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 @@ -7424,7 +7776,7 @@ is part of the perl-%s distribution. To install that, you need to run my $err = UNIVERSAL::can($self->{writemakefile},"text") ? $self->{writemakefile}->text : $self->{writemakefile}; - $err =~ s/^NO\s*//; + $err =~ s/^NO\s*(--\s+)?//; $err ||= "Had some problem writing Makefile"; $err .= ", won't make"; push @e, $err; @@ -7446,6 +7798,9 @@ is part of the perl-%s distribution. To install that, you need to run } } 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 } } @@ -7483,8 +7838,12 @@ is part of the perl-%s distribution. To install that, you need to run } local %ENV = %env; my $system; - if (my $commandline = $self->prefs->{pl}{commandline}) { - $system = $commandline; + 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'}; @@ -7498,7 +7857,7 @@ is part of the perl-%s distribution. To install that, you need to run # $switch = "-MExtUtils::MakeMaker ". # "-Mops=:default,:filesys_read,:filesys_open,require,chdir" # if $] > 5.00310; - my $makepl_arg = $self->make_x_arg("pl"); + 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", @@ -7507,9 +7866,13 @@ is part of the perl-%s distribution. To install that, you need to run $makepl_arg ? " $makepl_arg" : "", ); } - if (my $env = $self->prefs->{pl}{env}) { - for my $e (keys %$env) { - $ENV{$e} = $env->{$e}; + 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}) { @@ -7580,7 +7943,7 @@ is part of the perl-%s distribution. To install that, you need to run 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,$expect_model); + $ret = $self->_run_via_expect($system,'writemakefile',$expect_model); if (! defined $ret && $self->{writemakefile} && $self->{writemakefile}->failed) { @@ -7608,42 +7971,31 @@ is part of the perl-%s distribution. To install that, you need to run 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 -- No $makefile created}); + ->new(qq{NO -- $why\n}); $self->store_persistent_state; - return $self->goodbye("$system -- NO $makefile created"); + return $self->goodbye("$system -- NOT OK"); } } if ($CPAN::Signal) { delete $self->{force_update}; return; } - 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; - return $self->goodbye("[prereq] -- NOT OK"); - } 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($@); - return $self->goodbye("[depend] -- NOT OK"); - } - } - } + 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; } - if (my $commandline = $self->prefs->{make}{commandline}) { - $system = $commandline; + 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}) { @@ -7658,18 +8010,20 @@ is part of the perl-%s distribution. To install that, you need to run $system = join " ", $self->_make_command(), $CPAN::Config->{make_arg}; } $system =~ s/\s+$//; - my $make_arg = $self->make_x_arg("make"); + my $make_arg = $self->_make_phase_arg("make"); $system = sprintf("%s%s", $system, $make_arg ? " $make_arg" : "", ); } - if (my $env = $self->prefs->{make}{env}) { # overriding the local - # ENV of PL, not the - # outer ENV, but - # unlikely to be a risk - for my $e (keys %$env) { - $ENV{$e} = $env->{$e}; + 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"); @@ -7687,7 +8041,7 @@ is part of the perl-%s distribution. To install that, you need to run 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,$expect_model) == 0; + $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0; } elsif ( $self->_should_report('make') ) { my ($output, $ret) = CPAN::Reporter::record_command($system); @@ -7719,16 +8073,16 @@ sub goodbye { # CPAN::Distribution::_run_via_expect ; sub _run_via_expect { - my($self,$system,$expect_model) = @_; + 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,$expect_model); + return $self->_run_via_expect_deterministic($expo,$phase,$expect_model); } elsif ($expect_model->{mode} eq "anyorder") { - return $self->_run_via_expect_anyorder($expo,$expect_model); + return $self->_run_via_expect_anyorder($expo,$phase,$expect_model); } else { die "Panic: Illegal expect mode: $expect_model->{mode}"; } @@ -7739,14 +8093,20 @@ sub _run_via_expect { } sub _run_via_expect_anyorder { - my($self,$expo,$expect_model) = @_; + 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); - my @match = $expo->expect($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++; } ], @@ -7776,18 +8136,24 @@ sub _run_via_expect_anyorder { 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->{writemakefile} = + $self->{$phase} = CPAN::Distrostatus->new("NO $why"); - return; + return 0; } } } sub _run_via_expect_deterministic { - my($self,$expo,$expect_model) = @_; + 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) { @@ -7799,7 +8165,7 @@ sub _run_via_expect_deterministic { my $but = $expo->clear_accum; $CPAN::Frontend->mywarn("EOF (maybe harmless) expected[$regex]\nbut[$but]\n\n"); - last EXPECT; + $ran_into_eof++; } ], [ timeout => sub { my $but = $expo->clear_accum; @@ -7810,9 +8176,11 @@ expected[$regex]\nbut[$but]\n\n"); -re => $regex); if ($ran_into_timeout) { # note that the caller expects 0 for success - $self->{writemakefile} = + $self->{$phase} = CPAN::Distrostatus->new("NO timeout during expect dialog"); - return; + return 0; + } elsif ($ran_into_eof) { + last EXPECT; } $expo->send($send); } @@ -7849,18 +8217,17 @@ sub _find_prefs { $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)) { - push @extensions, "yml"; + $ext_map->{yml} = 'CPAN'; } else { my @fallbacks; if ($CPAN::META->has_inst("Data::Dumper")) { - push @extensions, "dd"; - push @fallbacks, "Data::Dumper"; + push @fallbacks, $ext_map->{dd} = 'Data::Dumper'; } if ($CPAN::META->has_inst("Storable")) { - push @extensions, "st"; - push @fallbacks, "Storable"; + push @fallbacks, $ext_map->{st} = 'Storable'; } if (@fallbacks) { local $" = " and "; @@ -7875,118 +8242,55 @@ sub _find_prefs { } } } - if (@extensions) { - my $dh = DirHandle->new($prefs_dir) - or die Carp::croak("Couldn't open '$prefs_dir': $!"); - DIRENT: for (sort $dh->read) { - next if $_ eq "." || $_ eq ".."; - my $exte = join "|", @extensions; - next unless /\.($exte)$/; - my $thisexte = $1; - my $abs = File::Spec->catfile($prefs_dir, $_); - if (-f $abs) { - #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG; - my @distropref; - if ($thisexte eq "yml") { - # need no eval because if we have no YAML we do not try to read *.yml - #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG; - @distropref = @{CPAN->_yaml_loadfile($abs)}; - #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG; - } elsif ($thisexte eq "dd") { - package CPAN::Eval; - no strict; - open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!"); - local $/; - my $eval = ; - close FH; - eval $eval; - if ($@) { - $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@"); - } - my $i = 1; - while (${"VAR".$i}) { - push @distropref, ${"VAR".$i}; - $i++; - } - } elsif ($thisexte eq "st") { - # eval because Storable is never forward compatible - eval { @distropref = @{scalar Storable::retrieve($abs)}; }; - if ($@) { - $CPAN::Frontend->mywarn("Error reading distroprefs file ". - "$_, skipping\: $@"); - $CPAN::Frontend->mysleep(4); - next DIRENT; - } - } - # $DB::single=1; - #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG; - ELEMENT: for my $y (0..$#distropref) { - my $distropref = $distropref[$y]; - $self->_validate_distropref($distropref,$abs,$y); - my $match = $distropref->{match}; - unless ($match) { - #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG; - next ELEMENT; - } - my $ok = 1; - # do not take the order of C because - # "module" is by far the slowest - my $saw_valid_subkeys = 0; - for my $sub_attribute (qw(distribution perl perlconfig module)) { - next unless exists $match->{$sub_attribute}; - $saw_valid_subkeys++; - my $qr = eval "qr{$distropref->{match}{$sub_attribute}}"; - if ($sub_attribute eq "module") { - my $okm = 0; - #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG; - my @modules = $self->containsmods; - #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG; - MODULE: for my $module (@modules) { - $okm ||= $module =~ /$qr/; - last MODULE if $okm; - } - $ok &&= $okm; - } elsif ($sub_attribute eq "distribution") { - my $okd = $distroid =~ /$qr/; - $ok &&= $okd; - } elsif ($sub_attribute eq "perl") { - my $okp = CPAN::find_perl =~ /$qr/; - $ok &&= $okp; - } elsif ($sub_attribute eq "perlconfig") { - for my $perlconfigkey (keys %{$match->{perlconfig}}) { - my $perlconfigval = $match->{perlconfig}->{$perlconfigkey}; - # XXX should probably warn if Config does not exist - my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/; - $ok &&= $okpc; - last if $ok == 0; - } - } else { - $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". - "unknown sub_attribut '$sub_attribute'. ". - "Please ". - "remove, cannot continue."); - } - last if $ok == 0; # short circuit - } - unless ($saw_valid_subkeys) { - $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ". - "missing match/* subattribute. ". - "Please ". - "remove, cannot continue."); - } - #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG; - if ($ok) { - return { - prefs => $distropref, - prefs_file => $abs, - prefs_file_doc => $y, - }; - } + 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, + }; } + } - $dh->close; } return; } @@ -8034,25 +8338,50 @@ $filler2 $bs $filler2 return $self->{prefs} = +{}; } -# CPAN::Distribution::make_x_arg -sub make_x_arg { - my($self, $whixh) = @_; - my $make_x_arg; +# CPAN::Distribution::_make_phase_arg +sub _make_phase_arg { + my($self, $phase) = @_; + my $_make_phase_arg; my $prefs = $self->prefs; if ( $prefs - && exists $prefs->{$whixh} - && exists $prefs->{$whixh}{args} - && $prefs->{$whixh}{args} + && exists $prefs->{$phase} + && exists $prefs->{$phase}{args} + && $prefs->{$phase}{args} ) { - $make_x_arg = join(" ", + $_make_phase_arg = join(" ", map {CPAN::HandleConfig - ->safe_quote($_)} @{$prefs->{$whixh}{args}}, + ->safe_quote($_)} @{$prefs->{$phase}{args}}, ); } - my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh; - $make_x_arg ||= $CPAN::Config->{$what}; - return $make_x_arg; + +# 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 @@ -8085,7 +8414,12 @@ sub follow_prereqs { my($slot) = shift; my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; return unless @prereq_tuples; - my @prereq = map { $_->[0] } @prereq_tuples; + my(@good_prereq_tuples); + for my $p (@prereq_tuples) { + # XXX watch out for foul ones + # $DB::single++; + push @good_prereq_tuples, $p; + } my $pretty_id = $self->pretty_id; my %map = ( b => "build_requires", @@ -8093,7 +8427,6 @@ sub follow_prereqs { c => "commandline", ); my($filler1,$filler2,$filler3,$filler4); - # $DB::single=1; my $unsat = "Unsatisfied dependencies detected during"; my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id); { @@ -8111,7 +8444,7 @@ sub follow_prereqs { $CPAN::Frontend-> myprint("$filler1 $unsat $filler2". "$filler3 $pretty_id $filler4". - join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples), + join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @good_prereq_tuples), ); my $follow = 0; if ($CPAN::Config->{prerequisites_policy} eq "follow") { @@ -8122,6 +8455,7 @@ sub follow_prereqs { 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"); @@ -8129,8 +8463,9 @@ of modules we are processing right now?", "yes"); if ($follow) { my $id = $self->id; # color them as dirty - for my $p (@prereq) { + 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) { @@ -8142,31 +8477,80 @@ of modules we are processing right now?", "yes"); } # queue them and re-queue yourself CPAN::Queue->jumpqueue({qmod => $id, reqtype => $self->{reqtype}}, - map {+{qmod=>$_->[0],reqtype=>$_->[1]}} reverse @prereq_tuples); + 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=>1],[Bar=>1.2]) for normal modules +# 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(); - %merged = (%{$meta_yml->{configure_requires}||{}}, - %{$prefs_depends->{configure_requires}||{}}); + 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 $k (keys %{$prefs_depends->{$reqtype}||{}}) { - $prereq_pm->{$reqtype}{$k} = $prefs_depends->{$reqtype}{$k}; + 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}||{}}); @@ -8203,44 +8587,9 @@ sub unsat_prereq { # or if the installed version is too old. We cannot omit this # check, because if 'force' is in effect, nobody else will check. if (defined $available_file) { - 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 { - last RQ; - } - } elsif ($rq =~ m|<=?\s*|) { - # 2005-12: no user - $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); - $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; - } - next NEED if $ok == @all_requirements; + my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs + ($need_module,$available_file,$available_version,$need_version); + next NEED if $fulfills_all_version_rqs; } if ($need_module eq "perl") { @@ -8248,7 +8597,7 @@ sub unsat_prereq { } $self->{sponsored_mods}{$need_module} ||= 0; CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG; - if ($self->{sponsored_mods}{$need_module}++) { + 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?? @@ -8297,6 +8646,8 @@ sub unsat_prereq { "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/) { @@ -8308,22 +8659,24 @@ sub unsat_prereq { } $CPAN::Frontend->mywarn("Warning: Prerequisite ". "'$need_module => $need_version' ". - "for '$self->{ID}' failed when ". - "processing '$do->{ID}' with ". + "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 eq "install") { + if ($nosayer =~ /^(install|make_test)$/) { # we had this with # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz - # 2007-03 + # in 2007-03 for 'make install' + # and 2008-04: #30464 (for 'make test') $CPAN::Frontend->mywarn("Warning: Prerequisite ". "'$need_module => $need_version' ". - "for '$self->{ID}' already installed ". - "but installation looks suspicious. ". - "Skipping another installation attempt, ". + "for '$selfid' already built ". + "but the result looks suspicious. ". + "Skipping another build attempt, ". "to prevent looping endlessly.\n" ); next NEED; @@ -8340,11 +8693,58 @@ sub unsat_prereq { @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 { + last RQ; + } + } elsif ($rq =~ m|<=?\s*|) { + # 2005-12: no user + $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n"); + $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; + } + return $ok == @all_requirements; +} + #-> sub CPAN::Distribution::read_yaml ; sub read_yaml { my($self) = @_; return $self->{yaml_content} if exists $self->{yaml_content}; - my $build_dir = $self->{build_dir}; + my $build_dir; + unless ($build_dir = $self->{build_dir}) { + # maybe permission on build_dir was missing + $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n"); + return; + } my $yaml = File::Spec->catfile($build_dir,"META.yml"); $self->debug("yaml[$yaml]") if $CPAN::DEBUG; return unless -f $yaml; @@ -8358,6 +8758,12 @@ sub read_yaml { # 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} = +{}; + } + } if (not exists $self->{yaml_content}{dynamic_config} or $self->{yaml_content}{dynamic_config} ) { @@ -8377,6 +8783,9 @@ sub prereq_pm { 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}||"", @@ -8419,7 +8828,10 @@ sub prereq_pm { } } unless ($req || $breq) { - my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; + my $build_dir; + unless ( $build_dir = $self->{build_dir} ) { + return; + } my $makefile = File::Spec->catfile($build_dir,"Makefile"); my $fh; if (-f $makefile @@ -8502,6 +8914,7 @@ sub test { return $self->goto($goto); } $self->make; + return if $self->prefs->{disabled} && ! $self->{force_update}; if ($CPAN::Signal) { delete $self->{force_update}; return; @@ -8518,6 +8931,7 @@ sub test { ? $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 @@ -8564,6 +8978,11 @@ sub test { } } 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) { @@ -8584,12 +9003,46 @@ sub test { } if ($self->{modulebuild}) { - my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version; + my $thm = CPAN::Shell->expand("Module","Test::Harness"); + my $v = $thm->inst_version; if (CPAN::Version->vlt($v,2.62)) { - $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only + # 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; + $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; + } + } } } @@ -8601,10 +9054,14 @@ sub test { $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_x_arg("test"); + my $make_test_arg = $self->_make_phase_arg("test"); $system = sprintf("%s%s", $system, $make_test_arg ? " $make_test_arg" : "", @@ -8616,9 +9073,13 @@ sub test { $env{$k} = $v; } local %ENV = %env; - if (my $env = $self->prefs->{test}{env}) { - for my $e (keys %$env) { - $ENV{$e} = $env->{$e}; + 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"); @@ -8638,7 +9099,7 @@ sub test { "not supported when distroprefs specify ". "an interactive test\n"); } - $tests_ok = $self->_run_via_expect($system,$expect_model) == 0; + $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; } elsif ( $self->_should_report('test') ) { $tests_ok = CPAN::Reporter::test($self, $system); } else { @@ -8975,8 +9436,10 @@ sub install { ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); + local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; $CPAN::META->set_perl5lib; - my($pipe) = FileHandle->new("$system $stderr |"); + my($pipe) = FileHandle->new("$system $stderr |") || Carp::croak +("Can't execute $system: $!"); my($makeout) = ""; while (<$pipe>) { print $_; # intentionally NOT use Frontend->myprint because it @@ -9259,6 +9722,14 @@ sub _should_report { 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( @@ -9489,8 +9960,8 @@ sub contains { my $in_cont = 0; $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; while (<$fh>) { - $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 : - m/^=head1\s+CONTENTS/ ? 1 : $in_cont; + $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 : + m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont; next unless $in_cont; next if /^=/; s/\#.*//; @@ -9565,13 +10036,16 @@ sub inst_file { $me[-1] .= ".pm"; my($incdir,$bestv); foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) { - my $bfile = File::Spec->catfile($incdir, @me); - CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG; - next unless -f $bfile; - my $foundv = MM->parse_version($bfile); - if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) { - $self->{INST_FILE} = $bfile; - $self->{INST_VERSION} = $bestv = $foundv; + my $parsefile = File::Spec->catfile($incdir, @me); + CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG; + next unless -f $parsefile; + my $have = eval { MM->parse_version($parsefile); }; + if ($@) { + $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n"); + } + if (!$bestv || CPAN::Version->vgt($have,$bestv)) { + $self->{INST_FILE} = $parsefile; + $self->{INST_VERSION} = $bestv = $have; } } $self->{INST_FILE}; @@ -9687,6 +10161,21 @@ sub distribution { CPAN::Shell->expand("Distribution",$self->cpan_file); } +#-> sub CPAN::Module::_is_representative_module +sub _is_representative_module { + my($self) = @_; + return $self->{_is_representative_module} if defined $self->{_is_representative_module}; + my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0; + $pm =~ s|.+/||; + $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id + $pm =~ s|-\d+\.\d+.+$||; + $pm =~ s|-[\d\.]+$||; + $pm =~ s/-/::/g; + $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0; + # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}"; + $self->{_is_representative_module}; +} + #-> sub CPAN::Module::undelay sub undelay { my $self = shift; @@ -9948,6 +10437,13 @@ sub as_string { $local_file || "(not installed)"); push @m, sprintf($sprintf, 'INST_VERSION', $self->inst_version) if $local_file; + if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow + my $available_file = $self->available_file; + if ($available_file && $available_file ne $local_file) { + push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file); + push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version); + } + } join "", @m, "\n"; } @@ -10176,7 +10672,7 @@ sub install { }); $CPAN::Frontend->mysleep(5); } - $self->rematein('install') if $doit; + return $doit ? $self->rematein('install') : 1; } #-> sub CPAN::Module::clean ; sub clean { shift->rematein('clean') } @@ -10194,7 +10690,12 @@ sub available_file { my $perllib = $ENV{PERL5LIB}; $perllib = $ENV{PERLLIB} unless defined $perllib; my @perllib = split(/$sep/,$perllib) if defined $perllib; - $self->_file_in_path([@perllib,@INC]); + my @cpan_perl5inc; + if ($CPAN::Perl5lib_tempfile) { + my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile); + @cpan_perl5inc = @{$yaml->[0]{inc} || []}; + } + $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]); } #-> sub CPAN::Module::file_in_path ; @@ -10250,8 +10751,12 @@ sub available_version { #-> sub CPAN::Module::parse_version ; sub parse_version { my($self,$parsefile) = @_; - my $have = MM->parse_version($parsefile); - $have = "undef" unless defined $have && length $have; + my $have = eval { MM->parse_version($parsefile); }; + if ($@) { + $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n"); + } + my $leastsanity = eval { defined $have && length $have; }; + $have = "undef" unless $leastsanity; $have =~ s/^ //; # since the %vd hack these two lines here are needed $have =~ s/ $//; # trailing whitespace happens all the time @@ -10383,6 +10888,44 @@ displayed with the rather verbose method C, but if we find more than one, we display each object with the terse method C. +Examples: + + cpan> m Acme::MetaSyntactic + Module id = Acme::MetaSyntactic + CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>) + CPAN_VERSION 0.99 + CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz + UPLOAD_DATE 2006-11-06 + MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names + INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm + INST_VERSION 0.99 + cpan> a BOOK + Author id = BOOK + EMAIL [...] + FULLNAME Philippe Bruhat (BooK) + cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz + Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz + CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>) + CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...] + UPLOAD_DATE 2006-11-06 + cpan> m /lorem/ + Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz) + Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz) + Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz) + Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz) + cpan> i /berlin/ + Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz + Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz) + Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz) + Author [...] + +The examples illustrate several aspects: the first three queries +target modules, authors, or distros directly and yield exactly one +result. The last two use regular expressions and yield several +results. The last one targets all of bundles, modules, authors, and +distros simultaneously. When more than one result is available, they +are printed in one-line format. + =item C, C, C, C, C modules or distributions These commands take any number of arguments and investigate what is @@ -10574,7 +11117,7 @@ current item. B: This command requires XML::LibXML installed. -B: This whole command currently is a bit klunky and will +B: This whole command currently is just a hack and will probably change in future versions of CPAN.pm but the general approach will likely stay. @@ -10618,7 +11161,7 @@ provided by the C command and tests them all. While the command is running $SIG{INT} is defined to mean that the current item shall be skipped. -B: This whole command currently is a bit klunky and will +B: This whole command currently is just a hack and will probably change in future versions of CPAN.pm but the general approach will likely stay. @@ -10699,6 +11242,13 @@ module or not. The typical usage case is for private modules or working copies of projects from remote repositories on the local disk. +=head2 Redirection + +The usual shell redirection symbols C< | > and C<< > >> are recognized +by the cpan shell when surrounded by whitespace. So piping into a +pager and redirecting output into a file works quite similar to any +shell. + =head1 CONFIGURATION When the CPAN module is used for the first time, a configuration @@ -10803,10 +11353,6 @@ defined: only needed for building. yes|no|ask/yes|ask/no bzip2 path to external prg cache_metadata use serializer to cache metadata - commands_quote prefered character to use for quoting external - commands when running them. Defaults to double - quote on Windows, single tick everywhere else; - can be set to space to disable quoting check_sigs if signatures should be verified colorize_debug Term::ANSIColor attributes for debugging output colorize_output boolean if Term::ANSIColor should colorize output @@ -10814,6 +11360,13 @@ defined: colorize_warn Term::ANSIColor attributes for warnings commandnumber_in_prompt boolean if you want to see current command number + commands_quote prefered character to use for quoting external + commands when running them. Defaults to double + quote on Windows, single tick everywhere else; + can be set to space to disable quoting + connect_to_internet_ok + if we shall ask if opening a connection is ok before + urllist is specified cpan_home local directory reserved for this package curl path to external prg dontload_hash DEPRECATED @@ -10822,9 +11375,13 @@ defined: ftp path to external prg ftp_passive if set, the envariable FTP_PASSIVE is set for downloads ftp_proxy proxy host for ftp requests + ftpstats_period max number of days to keep download statistics + ftpstats_size max number of items to keep in the download statistics getcwd see below gpg path to external prg gzip location of external program gzip + halt_on_failure stop processing after the first failure of queued + items or dependencies histfile file to maintain history between sessions histsize maximum number of lines to keep in histfile http_proxy proxy host for http requests @@ -10857,6 +11414,7 @@ defined: pager location of external program more (or any pager) password your password if you CPAN server wants one patch path to external prg + perl5lib_verbosity verbosity level for PERL5LIB additions prefer_installer legal values are MB and EUMM: if a module comes with both a Makefile.PL and a Build.PL, use the former (EUMM) or the latter (MB); if the module @@ -10881,13 +11439,16 @@ defined: (and nonsense for characters outside latin range) term_ornaments boolean to turn ReadLine ornamenting on/off test_report email test reports (if CPAN::Reporter is installed) + trust_test_report_history + skip testing when previously tested ok (according to + CPAN::Reporter history) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) use_sqlite use CPAN::SQLite for metadata storage (fast and lean) username your username if you CPAN server wants one wait_list arrayref to a wait server to try (See CPAN::WAIT) wget path to external prg - yaml_load_code enable YAML code deserialisation + yaml_load_code enable YAML code deserialisation via CPAN::DeferedCode yaml_module which module to use to read/write YAML files You can set and query each of these options interactively in the cpan @@ -11137,6 +11698,8 @@ C. perl: "/usr/local/cariba-perl/bin/perl" perlconfig: archname: "freebsd" + env: + DANCING_FLOOR: "Shubiduh" disabled: 1 cpanconfig: make: gmake @@ -11223,6 +11786,13 @@ declaration. Specifies that this distribution shall not be processed at all. +=item features [array] *** EXPERIMENTAL FEATURE *** + +Experimental implementation to deal with optional_features from +META.yml. Still needs coordination with installer software and +currently only works for META.yml declaring C. Use +with caution. + =item goto [string] The canonical name of a delegate distribution that shall be installed @@ -11233,18 +11803,18 @@ uploaded that is better than the last released version. =item install [hash] Processing instructions for the C or C<./Build install> -phase of the CPAN mantra. See below under I. +phase of the CPAN mantra. See below under I. =item make [hash] Processing instructions for the C or C<./Build> phase of the -CPAN mantra. See below under I. +CPAN mantra. See below under I. =item match [hash] A hashref with one or more of the keys C, C, -C, and C that specify if a document is targeted at a -specific CPAN distribution or installation. +C, C, and C that specify if a document is +targeted at a specific CPAN distribution or installation. The corresponding values are interpreted as regular expressions. The C related one will be matched against the canonical @@ -11258,13 +11828,16 @@ absolute path). The value associated with C is itself a hashref that is matched against corresponding values in the C<%Config::Config> hash -living in the C< Config.pm > module. +living in the C module. -If more than one restriction of C, C, and -C is specified, the results of the separately computed match -values must all match. If this is the case then the hashref -represented by the YAML document is returned as the preference -structure for the current distribution. +The value associated with C is itself a hashref that is +matched against corresponding values in the C<%ENV> hash. + +If more than one restriction of C, C, etc. is +specified, the results of the separately computed match values must +all match. If this is the case then the hashref represented by the +YAML document is returned as the preference structure for the current +distribution. =item patches [array] @@ -11282,13 +11855,13 @@ distribution. =item pl [hash] Processing instructions for the C or C phase of the CPAN mantra. See below under I phase of the CPAN mantra. See below under I. =item test [hash] Processing instructions for the C or C<./Build test> phase -of the CPAN mantra. See below under I. +of the CPAN mantra. See below under I. =back @@ -11645,11 +12218,6 @@ Normally this is derived from the file name only, but the index from CPAN can contain a hint to achieve a return value of true for other filenames too. -=item CPAN::Distribution::is_tested() - -List all the distributions that have been tested sucessfully but not -yet installed. See also C. - =item CPAN::Distribution::look() Changes to the directory where the distribution has been unpacked and @@ -12498,7 +13066,8 @@ http://www.refcnt.org/papers/module-build-convert =item 15) -What's the best CPAN site for me? +I'm frequently irritated with the CPAN shell's inability to help me +select a good mirror. The urllist config parameter is yours. You can add and remove sites at will. You should find out which sites have the best uptodateness, @@ -12510,6 +13079,14 @@ Henk P. Penning maintains a site that collects data about CPAN sites: http://www.cs.uu.nl/people/henkp/mirmon/cpan.html +Also, feel free to play with experimental features. Run + + o conf init randomize_urllist ftpstats_period ftpstats_size + +and choose your favorite parameters. After a few downloads running the +C command will probably assist you in choosing the best mirror +sites. + =item 16) Why do I get asked the same questions every time I start the shell? @@ -12519,6 +13096,26 @@ command C. Alternatively set the C variable to true by running C and answering the following question with yes. +=item 17) + +Older versions of CPAN.pm had the original root directory of all +tarballs in the build directory. Now there are always random +characters appended to these directory names. Why was this done? + +The random characters are provided by File::Temp and ensure that each +module's individual build directory is unique. This makes running +CPAN.pm in concurrent processes simultaneously safe. + +=item 18) + +Speaking of the build directory. Do I have to clean it up myself? + +You have the choice to set the config variable C to +C. Then you must clean it up yourself. The other possible +value, C only cleans up the build directory when you start +the CPAN shell. If you never start up the CPAN shell, you probably +also have to clean up the build directory yourself. + =back =head1 COMPATIBILITY diff --git a/lib/CPAN/API/HOWTO.pm b/lib/CPAN/API/HOWTO.pod similarity index 100% rename from lib/CPAN/API/HOWTO.pm rename to lib/CPAN/API/HOWTO.pod diff --git a/lib/CPAN/Debug.pm b/lib/CPAN/Debug.pm index 086b623..926b0d7 100644 --- a/lib/CPAN/Debug.pm +++ b/lib/CPAN/Debug.pm @@ -3,7 +3,7 @@ package CPAN::Debug; use strict; use vars qw($VERSION); -$VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; +$VERSION = "5.5"; # module is internal to CPAN.pm %CPAN::DEBUG = qw[ diff --git a/lib/CPAN/Distroprefs.pm b/lib/CPAN/Distroprefs.pm new file mode 100644 index 0000000..664ddb7 --- /dev/null +++ b/lib/CPAN/Distroprefs.pm @@ -0,0 +1,413 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: + +use strict; +package CPAN::Distroprefs; + +use vars qw($VERSION); +$VERSION = '6'; + +package CPAN::Distroprefs::Result; + +use File::Spec; + +sub new { bless $_[1] || {} => $_[0] } + +sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) } + +sub __cloner { + my ($class, $name, $newclass) = @_; + $newclass = 'CPAN::Distroprefs::Result::' . $newclass; + no strict 'refs'; + *{$class . '::' . $name} = sub { + $newclass->new({ + %{ $_[0] }, + %{ $_[1] }, + }); + }; +} +BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') } +BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') } +BEGIN { __PACKAGE__->__cloner(as_success => 'Success') } + +sub __accessor { + my ($class, $key) = @_; + no strict 'refs'; + *{$class . '::' . $key} = sub { $_[0]->{$key} }; +} +BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) } + +sub is_warning { 0 } +sub is_fatal { 0 } +sub is_success { 0 } + +package CPAN::Distroprefs::Result::Error; +use vars qw(@ISA); +BEGIN { @ISA = 'CPAN::Distroprefs::Result' } +BEGIN { __PACKAGE__->__accessor($_) for qw(msg) } + +sub as_string { + my ($self) = @_; + if ($self->msg) { + return sprintf $self->fmt_reason, $self->file, $self->msg; + } else { + return sprintf $self->fmt_unknown, $self->file; + } +} + +package CPAN::Distroprefs::Result::Warning; +use vars qw(@ISA); +BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } +sub is_warning { 1 } +sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" } +sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." } + +package CPAN::Distroprefs::Result::Fatal; +use vars qw(@ISA); +BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } +sub is_fatal { 1 } +sub fmt_reason { "Error reading distroprefs file %s: %s" } +sub fmt_unknown { "Unknown error reading distroprefs file %s." } + +package CPAN::Distroprefs::Result::Success; +use vars qw(@ISA); +BEGIN { @ISA = 'CPAN::Distroprefs::Result' } +BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) } +sub is_success { 1 } + +package CPAN::Distroprefs::Iterator; + +sub new { bless $_[1] => $_[0] } + +sub next { $_[0]->() } + +package CPAN::Distroprefs; + +use Carp (); +use DirHandle; + +sub _load_method { + my ($self, $loader, $result) = @_; + return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/; + return '_load_' . $result->ext; +} + +sub _load_yaml { + my ($self, $loader, $result) = @_; + my $data = eval { + $loader eq 'CPAN' + ? $loader->_yaml_loadfile($result->abs) + : [ $loader->can('LoadFile')->($result->abs) ] + }; + if (my $err = $@) { + die $result->as_warning({ + msg => $err, + }); + } elsif (!$data) { + die $result->as_warning; + } else { + return @$data; + } +} + +sub _load_dd { + my ($self, $loader, $result) = @_; + my @data; + { + package CPAN::Eval; + # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm + # not sure why we wouldn't just skip the file as we do for all other + # errors. -- hdp + my $abs = $result->abs; + open FH, "<$abs" or die $result->as_fatal(msg => "$!"); + local $/; + my $eval = ; + close FH; + no strict; + eval $eval; + if (my $err = $@) { + die $result->as_warning({ msg => $err }); + } + my $i = 1; + while (${"VAR$i"}) { + push @data, ${"VAR$i"}; + $i++; + } + } + return @data; +} + +sub _load_st { + my ($self, $loader, $result) = @_; + # eval because Storable is never forward compatible + my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } }; + if (my $err = $@) { + die $result->as_warning({ msg => $err }); + } + return @data; +} + +sub find { + my ($self, $dir, $ext_map) = @_; + + my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!"); + my @files = sort $dh->read; + + # label the block so that we can use redo in the middle + return CPAN::Distroprefs::Iterator->new(sub { LOOP: { + return unless %$ext_map; + + local $_ = shift @files; + return unless defined; + redo if $_ eq '.' || $_ eq '..'; + + my $possible_ext = join "|", map { quotemeta } keys %$ext_map; + my ($ext) = /\.($possible_ext)$/ or redo; + my $loader = $ext_map->{$ext}; + + my $result = CPAN::Distroprefs::Result->new({ + file => $_, ext => $ext, dir => $dir + }); + # copied from CPAN.pm; is this ever actually possible? + redo unless -f $result->abs; + + my $load_method = $self->_load_method($loader, $result); + my @prefs = eval { $self->$load_method($loader, $result) }; + if (my $err = $@) { + if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) { + return $err; + } + # rethrow any exceptions that we did not generate + die $err; + } elsif (!@prefs) { + # the loader should have handled this, but just in case: + return $result->as_warning; + } + return $result->as_success({ + prefs => [ + map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs + ], + }); + } }); +} + +package CPAN::Distroprefs::Pref; + +use Carp (); + +sub new { bless $_[1] => $_[0] } + +sub data { shift->{data} } + +sub has_any_match { $_[0]->data->{match} ? 1 : 0 } + +sub has_match { exists $_[0]->data->{match}{$_[1]} } + +sub has_valid_subkeys { + grep { exists $_[0]->data->{match}{$_} } + $_[0]->match_attributes +} + +sub _pattern { + my ($self, $key) = @_; + return eval sprintf 'qr{%s}', $self->data->{match}{$key}; +} + +sub _scalar_match { + my ($self, $key, $data) = @_; + my $qr = $self->_pattern($key); + return $data =~ /$qr/ ? 1 : 0; +} + +sub _hash_match { + my ($self, $key, $data) = @_; + my $match = $self->data->{match}{$key}; + for my $mkey (keys %$match) { + my $val = defined $data->{$mkey} ? $data->{$mkey} : ''; + my $qr = eval sprintf 'qr{%s}', $match->{$mkey}; + return 0 unless $val =~ /$qr/; + } + return 1; +} + +# do not take the order of C because "module" is by far the +# slowest +sub match_attributes { qw(env distribution perl perlconfig module) } + +sub match_module { + my ($self, $modules) = @_; + my $qr = $self->_pattern('module'); + for my $module (@$modules) { + return 1 if $module =~ /$qr/; + } + return 0; +} + +sub match_distribution { shift->_scalar_match(distribution => @_) } +sub match_perl { shift->_scalar_match(perl => @_) } + +sub match_perlconfig { shift->_hash_match(perlconfig => @_) } +sub match_env { shift->_hash_match(env => @_) } + +sub matches { + my ($self, $arg) = @_; + + my $default_match = 0; + for my $key (grep { $self->has_match($_) } $self->match_attributes) { + unless (exists $arg->{$key}) { + Carp::croak "Can't match pref: missing argument key $key"; + } + $default_match = 1; + my $val = $arg->{$key}; + # make it possible to avoid computing things until we have to + if (ref($val) eq 'CODE') { $val = $val->() } + my $meth = "match_$key"; + return 0 unless $self->$meth($val); + } + + return $default_match; +} + +1; + +__END__ + +=head1 NAME + +CPAN::Distroprefs -- read and match distroprefs + +=head1 SYNOPSIS + + use CPAN::Distroprefs; + + my %info = (... distribution/environment info ...); + + my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map); + + while (my $result = $finder->next) { + + die $result->as_string if $result->is_fatal; + + warn $result->as_string, next if $result->is_warning; + + for my $pref (@{ $result->prefs }) { + if ($pref->matches(\%info)) { + return $pref; + } + } + } + + +=head1 DESCRIPTION + +This module encapsulates reading L and matching them against CPAN distributions. + +=head1 INTERFACE + + my $finder = CPAN::Distroprefs->find($dir, \%ext_map); + + while (my $result = $finder->next) { ... } + +Build an iterator which finds distroprefs files in the given directory. + +C<%ext_map> is a hashref whose keys are file extensions and whose values are +modules used to load matching files: + + { + 'yml' => 'YAML::Syck', + 'dd' => 'Data::Dumper', + ... + } + +Each time C<< $finder->next >> is called, the iterator returns one of two +possible values: + +=over + +=item * a CPAN::Distroprefs::Result object + +=item * C, indicating that no prefs files remain to be found + +=back + +=head1 RESULTS + +L|/INTERFACE> returns CPAN::Distroprefs::Result objects to +indicate success or failure when reading a prefs file. + +=head2 Common + +All results share some common attributes: + +=head3 type + +C, C, or C + +=head3 file + +the file from which these prefs were read, or to which this error refers (relative filename) + +=head3 ext + +the file's extension, which determines how to load it + +=head3 dir + +the directory the file was read from + +=head3 abs + +the absolute path to the file + +=head2 Errors + +Error results (warning and fatal) contain: + +=head3 msg + +the error message (usually either C<$!> or a YAML error) + +=head2 Successes + +Success results contain: + +=head3 prefs + +an arrayref of CPAN::Distroprefs::Pref objects + +=head1 PREFS + +CPAN::Distroprefs::Pref objects represent individual distroprefs documents. +They are constructed automatically as part of C results from C. + +=head3 data + +the pref information as a hashref, suitable for e.g. passing to Kwalify + +=head3 match_attributes + +returns a list of the valid match attributes (see the Distroprefs section in L) + +currently: C + +=head3 has_any_match + +true if this pref has a 'match' attribute at all + +=head3 has_valid_subkeys + +true if this pref has a 'match' attribute and at least one valid match attribute + +=head3 matches + + if ($pref->matches(\%arg)) { ... } + +true if this pref matches the passed-in hashref, which must have a value for +each of the C (above) + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index d5d3e21..9a79b5a 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -19,7 +19,7 @@ use File::Basename (); use File::Path (); use File::Spec (); use vars qw($VERSION $urllist); -$VERSION = sprintf "%.6f", substr(q$Rev: 2229 $,4)/1000000 + 5.4; +$VERSION = "5.5"; =head1 NAME @@ -160,11 +160,38 @@ for easier tracking of the session or be a plain string. Do you want the command number in the prompt (yes/no)? +=item connect_to_internet_ok + +If you have never defined your own C in your configuration +then C will be hesitant to use the built in default sites for +downloading. It will ask you once per session if a connection to the +internet is OK and only if you say yes, it will try to connect. But to +avoid this question, you can choose your favorite download sites once +and get away with it. Or, if you have no favorite download sites +answer yes to the following question. + +If no urllist has been chosen yet, would you prefer CPAN.pm to connect +to the built-in default sites without asking? (yes/no)? + =item ftp_passive Shall we always set the FTP_PASSIVE environment variable when dealing with ftp download (yes/no)? +=item ftpstats_period + +Statistics about downloads are truncated by size and period +simultaneously. + +How many days shall we keep statistics about downloads? + +=item ftpstats_size + +Statistics about downloads are truncated by size and period +simultaneously. + +How many items shall we keep in the statistics about downloads? + =item getcwd CPAN.pm changes the current working directory often and needs to @@ -179,6 +206,14 @@ alternatives can be configured according to the following table: Preferred method for determining the current working directory? +=item halt_on_failure + +Normaly, CPAN.pm continues processing the full list of targets and +dependencies, even if one of them fails. However, you can specify +that CPAN should halt after the first failure. + +Do you want to halt on failure (yes/no)? + =item histfile If you have one of the readline packages (Term::ReadLine::Perl, @@ -244,7 +279,7 @@ Verbosity level for loading modules (none or v)? Every Makefile.PL is run by perl in a separate process. Likewise we run 'make' and 'make install' in separate processes. If you have -any parameters (e.g. PREFIX, LIB, UNINST or the like) you want to +any parameters (e.g. PREFIX, UNINST or the like) you want to pass to the calls, please specify them here. If you don't understand this question, just press ENTER. @@ -475,6 +510,26 @@ you will need to configure CPAN::Reporter before sending reports. Email test reports if CPAN::Reporter is installed (yes/no)? +=item perl5lib_verbosity + +When CPAN.pm extends @INC via PERL5LIB, it prints a list of +directories added (or a summary of how many directories are +added). Choose 'v' to get this message, 'none' to suppress it. + +Verbosity level for PERL5LIB changes (none or v)? + +=item trust_test_report_history + +When a distribution has already been tested by CPAN::Reporter on +this machine, CPAN can skip the test phase and just rely on the +test report history instead. + +Note that this will not apply to distributions that failed tests +because of missing dependencies. Also, tests can be run +regardless of the history using "force". + +Do you want to rely on the test report history (yes/no)? + =item use_sqlite CPAN::SQLite is a layer between the index files that are downloaded @@ -485,9 +540,10 @@ Use CPAN::SQLite if available? (yes/no)? =item yaml_load_code -Both YAML.pm and YAML::Syck are capable of deserialising code. As this requires -a string eval, which might be a security risk, you can use this option to -enable or disable the deserialisation of code. +Both YAML.pm and YAML::Syck are capable of deserialising code. As this +requires a string eval, which might be a security risk, you can use +this option to enable or disable the deserialisation of code via +CPAN::DeferedCode. (Note: This does not work under perl 5.6) Do you want to enable code deserialisation (yes/no)? @@ -631,7 +687,7 @@ sub init { if (!$matcher or 'cpan_home' =~ /$matcher/) { my $cpan_home = $CPAN::Config->{cpan_home} - || File::Spec->catdir($ENV{HOME}, ".cpan"); + || File::Spec->catdir(CPAN::HandleConfig::home(), ".cpan"); if (-d $cpan_home) { $CPAN::Frontend->myprint(qq{ @@ -708,7 +764,7 @@ Shall we use it as the general CPAN build and cache directory? } if (!$matcher or 'build_dir_reuse' =~ /$matcher/) { - my_yn_prompt(build_dir_reuse => 1, $matcher); + my_yn_prompt(build_dir_reuse => 0, $matcher); } if (!$matcher or 'prefs_dir' =~ /$matcher/) { @@ -786,6 +842,10 @@ Shall we use it as the general CPAN build and cache directory? } } + if (!$matcher or 'trust_test_report_history' =~ /$matcher/) { + my_yn_prompt(trust_test_report_history => 0, $matcher); + } + # #= YAML vs. YAML::Syck # @@ -929,6 +989,11 @@ substitute. You can then revisit this dialog with 'none|v'); } + if (!$matcher or 'perl5lib_verbosity' =~ /$matcher/) { + my_prompt_loop(perl5lib_verbosity => 'v', $matcher, + 'none|v'); + } + my_yn_prompt(inhibit_startup_message => 0, $matcher); # @@ -942,6 +1007,13 @@ substitute. You can then revisit this dialog with if (!$matcher or 'makepl_arg make_arg' =~ /$matcher/) { my_dflt_prompt(makepl_arg => "", $matcher); my_dflt_prompt(make_arg => "", $matcher); + if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) { + $CPAN::Frontend->mywarn( + "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" . + "that specify their own LIBS or INC options in Makefile.PL.\n" + ); + } + } require CPAN::HandleConfig; @@ -958,7 +1030,8 @@ substitute. You can then revisit this dialog with my_dflt_prompt(mbuildpl_arg => "", $matcher); my_dflt_prompt(mbuild_arg => "", $matcher); - if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command}) { + if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command} + and $^O ne "MSWin32") { # as long as Windows needs $self->_build_command, we cannot # support sudo on windows :-) my_dflt_prompt(mbuild_install_build_command => "./Build", $matcher); @@ -973,6 +1046,13 @@ substitute. You can then revisit this dialog with my_dflt_prompt(inactivity_timeout => 0, $matcher); # + #== halt_on_failure + # + if (!$matcher or 'halt_on_failure' =~ /$matcher/) { + my_yn_prompt(halt_on_failure => 0, $matcher); + } + + # #= Proxies # @@ -1118,6 +1198,7 @@ substitute. You can then revisit this dialog with #= MIRRORED.BY and conf_sites() # + my_yn_prompt("connect_to_internet_ok" => 0, $matcher); if ($matcher) { if ("urllist" =~ $matcher) { # conf_sites would go into endless loop with the smash prompt @@ -1128,10 +1209,16 @@ substitute. You can then revisit this dialog with if ("randomize_urllist" =~ $matcher) { my_dflt_prompt(randomize_urllist => 0, $matcher); } + if ("ftpstats_size" =~ $matcher) { + my_dflt_prompt(ftpstats_size => 99, $matcher); + } + if ("ftpstats_period" =~ $matcher) { + my_dflt_prompt(ftpstats_period => 14, $matcher); + } } elsif ($fastread) { $CPAN::Frontend->myprint("Autoconfigured everything but 'urllist'.\n". "Please call 'o conf init urllist' to configure ". - "your CPAN server(s) now!"); + "your CPAN server(s) now!\n\n"); } else { conf_sites(); } @@ -1523,7 +1610,9 @@ config_intro => qq{ The following questions are intended to help you with the configuration. The CPAN module needs a directory of its own to cache important index files and maybe keep a temporary mirror of CPAN files. -This may be a site-wide or a personal directory.}, +This may be a site-wide or a personal directory. + +}, # cpan_home => qq{ }, diff --git a/lib/CPAN/HandleConfig.pm b/lib/CPAN/HandleConfig.pm index ec0aefd..ce68f90 100644 --- a/lib/CPAN/HandleConfig.pm +++ b/lib/CPAN/HandleConfig.pm @@ -2,7 +2,7 @@ package CPAN::HandleConfig; use strict; use vars qw(%can %keys $loading $VERSION); -$VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; +$VERSION = "5.5"; %can = ( commit => "Commit changes to disk", @@ -14,6 +14,13 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; # Q: where is the "How do I add a new config option" HOWTO? # A1: svn diff -r 757:758 # where dagolden added test_report # A2: svn diff -r 985:986 # where andk added yaml_module +# A3: 1. add new config option to %keys below +# 2. add a Pod description in CPAN::FirstTime; it should include a +# prompt line; see others for examples +# 3. add a "matcher" section in CPAN::FirstTime::init that includes +# a prompt function; see others for examples +# 4. add config option to documentation section in CPAN.pm + %keys = map { $_ => undef } ( "applypatch", @@ -31,6 +38,7 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; "colorize_warn", "commandnumber_in_prompt", "commands_quote", + "connect_to_internet_ok", "cpan_home", "curl", "dontload_hash", # deprecated after 1.83_68 (rev. 581) @@ -38,9 +46,12 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; "ftp", "ftp_passive", "ftp_proxy", + "ftpstats_size", + "ftpstats_period", "getcwd", "gpg", "gzip", + "halt_on_failure", "histfile", "histsize", "http_proxy", @@ -65,6 +76,7 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; "pager", "password", "patch", + "perl5lib_verbosity", "prefer_installer", "prefs_dir", "prerequisites_policy", @@ -81,6 +93,7 @@ $VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; "term_is_latin", "term_ornaments", "test_report", + "trust_test_report_history", "unzip", "urllist", "use_sqlite", @@ -101,21 +114,6 @@ my %prefssupport = map { $_ => 1 } "test_report", ); -if ($^O eq "MSWin32") { - for my $k (qw( - mbuild_install_build_command - make_install_make_command - )) { - delete $keys{$k}; - if (exists $CPAN::Config->{$k}) { - for ("deleting previously set config variable '$k' => '$CPAN::Config->{$k}'") { - $CPAN::Frontend ? $CPAN::Frontend->mywarn($_) : warn $_; - } - delete $CPAN::Config->{$k}; - } - } -} - # returns true on successful action sub edit { my($self,@args) = @_; @@ -123,7 +121,6 @@ sub edit { CPAN->debug("self[$self]args[".join(" | ",@args)."]"); my($o,$str,$func,$args,$key_exists); $o = shift @args; - $DB::single = 1; if($can{$o}) { $self->$o(args => \@args); # o conf init => sub init => sub load return 1; @@ -289,12 +286,13 @@ Please specify a filename where to save the configuration or try } my $msg; + my $home = home(); $msg = <{load_module_verbosity}; + $CPAN::Config->{load_module_verbosity} = q[none]; if ($CPAN::META->has_usable("File::HomeDir")) { - $home = File::HomeDir->my_data; + $home = File::HomeDir->can('my_dot_config') + ? File::HomeDir->my_dot_config + : File::HomeDir->my_data; unless (defined $home) { $home = File::HomeDir->my_home } @@ -500,6 +510,7 @@ sub home () { unless (defined $home) { $home = $ENV{HOME}; } + $CPAN::Config->{load_module_verbosity} = $old_v; $home; } @@ -586,7 +597,7 @@ sub missing_config_data { "makepl_arg", "mbuild_arg", "mbuild_install_arg", - "mbuild_install_build_command", + ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"), "mbuildpl_arg", "no_proxy", #"pager", @@ -690,7 +701,7 @@ sub prefs_lookup { use strict; use vars qw($AUTOLOAD $VERSION); - $VERSION = sprintf "%.2f", substr(q$Rev: 2212 $,4)/100; + $VERSION = "5.5"; # formerly CPAN::HandleConfig was known as CPAN::Config sub AUTOLOAD { diff --git a/lib/CPAN/Kwalify.pm b/lib/CPAN/Kwalify.pm index 77564cb..3cade90 100644 --- a/lib/CPAN/Kwalify.pm +++ b/lib/CPAN/Kwalify.pm @@ -49,7 +49,7 @@ use strict; package CPAN::Kwalify; use vars qw($VERSION $VAR1); -$VERSION = sprintf "%.6f", substr(q$Rev: 1418 $,4)/1000000 + 5.4; +$VERSION = "5.50"; use File::Spec (); @@ -85,7 +85,9 @@ sub _validate { }; $VAR1 = undef; eval $content; - die "parsing of '$schema_name.dd' failed: $@" if $@; + if (my $err = $@) { + die "parsing of '$schema_name.dd' failed: $err"; + } $schema_loaded->{$schema_name} = $VAR1; } } @@ -97,8 +99,9 @@ sub _validate { } return if $vcache{$abs}{$mtime}{$y}++; eval { Kwalify::validate($schema, $data) }; - if ($@) { - die "validation of distropref '$abs'[$y] failed: $@"; + if (my $err = $@) { + my $info = {}; yaml($schema_name, info => $info); + die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err"; } } } @@ -108,11 +111,14 @@ sub _clear_cache { } sub yaml { - my($schema_name) = @_; + my($schema_name, %opt) = @_; my $content = do { my $path = __FILE__; $path =~ s/\.pm$//; $path = File::Spec->catfile($path, "$schema_name.yml"); + if ($opt{info}) { + $opt{info}{path} = $path; + } local *FH; open FH, $path or die "Could not open '$path': $!"; local $/; diff --git a/lib/CPAN/Kwalify/distroprefs.dd b/lib/CPAN/Kwalify/distroprefs.dd index 52118e5..fd04627 100644 --- a/lib/CPAN/Kwalify/distroprefs.dd +++ b/lib/CPAN/Kwalify/distroprefs.dd @@ -33,6 +33,14 @@ $VAR1 = { ], "type" => "int" }, + "features" => { + "sequence" => [ + { + "type" => "text" + } + ], + "type" => "seq" + }, "goto" => { "type" => "text" }, @@ -100,20 +108,21 @@ $VAR1 = { "distribution" => { "type" => "text" }, - "module" => { - "type" => "text" - }, - "perl" => { - "type" => "text" - }, - "perlconfig" => { + "env" => { "mapping" => { "=" => { "type" => "text" } }, "type" => "map" - } + }, + "module" => { + "type" => "text" + }, + "perl" => { + "type" => "text" + }, + "perlconfig" => {} }, "type" => "map" }, @@ -126,6 +135,9 @@ $VAR1 = { "type" => "seq" }, "pl" => {}, + "reminder" => { + "type" => "text" + }, "test" => {} }, "type" => "map" @@ -133,5 +145,6 @@ $VAR1 = { $VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"}; $VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"}; $VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"}; +$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"}; $VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"}; $VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"}; diff --git a/lib/CPAN/Kwalify/distroprefs.yml b/lib/CPAN/Kwalify/distroprefs.yml index 68ff72b..431f174 100644 --- a/lib/CPAN/Kwalify/distroprefs.yml +++ b/lib/CPAN/Kwalify/distroprefs.yml @@ -24,10 +24,12 @@ mapping: perl: type: text perlconfig: + &matchhash_common type: map mapping: =: type: text + env: *matchhash_common install: &args_env_expect type: map @@ -82,3 +84,9 @@ mapping: mapping: =: type: text + features: + type: seq + sequence: + - type: text + reminder: + type: text diff --git a/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm index d968f96..5fe5a25 100644 --- a/lib/CPAN/Nox.pm +++ b/lib/CPAN/Nox.pm @@ -9,7 +9,7 @@ BEGIN{ use base 'Exporter'; use CPAN; -$VERSION = sprintf "%.6f", substr(q$Rev: 2411 $,4)/1000000 + 5.4; +$VERSION = "5.50"; $CPAN::META->has_inst('Digest::MD5','no'); $CPAN::META->has_inst('LWP','no'); $CPAN::META->has_inst('Compress::Zlib','no'); diff --git a/lib/CPAN/Queue.pm b/lib/CPAN/Queue.pm index f01ab51..b60f57c 100644 --- a/lib/CPAN/Queue.pm +++ b/lib/CPAN/Queue.pm @@ -67,7 +67,7 @@ package CPAN::Queue; # in CPAN::Distribution::rematein. use vars qw{ @All $VERSION }; -$VERSION = sprintf "%.6f", substr(q$Rev: 2212 $,4)/1000000 + 5.4; +$VERSION = "5.5"; # CPAN::Queue::queue_item ; sub queue_item { @@ -181,6 +181,11 @@ sub nullify_queue { @All = (); } +# CPAN::Queue::size ; +sub size { + return scalar @All; +} + 1; __END__ diff --git a/lib/CPAN/Tarzip.pm b/lib/CPAN/Tarzip.pm index a9cad24..73986bf 100644 --- a/lib/CPAN/Tarzip.pm +++ b/lib/CPAN/Tarzip.pm @@ -3,8 +3,8 @@ package CPAN::Tarzip; use strict; use vars qw($VERSION @ISA $BUGHUNTING); use CPAN::Debug; -use File::Basename (); -$VERSION = sprintf "%.6f", substr(q$Rev: 2213 $,4)/1000000 + 5.4; +use File::Basename qw(basename); +$VERSION = "5.5"; # module is internal to CPAN.pm @ISA = qw(CPAN::Debug); @@ -23,12 +23,9 @@ sub new { if (0) { } elsif ($file =~ /\.bz2$/i) { unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) { - my $bzip2; - if ($CPAN::META->has_inst("File::Which")) { - $bzip2 = File::Which::which("bzip2"); - } + my $bzip2 = _my_which("bzip2"); if ($bzip2) { - $me->{UNGZIPPRG} = $bzip2 || "bzip2"; + $me->{UNGZIPPRG} = $bzip2; } else { $CPAN::Frontend->mydie(qq{ CPAN.pm needs the external program bzip2 in order to handle '$file'. @@ -38,12 +35,34 @@ program. } } } else { - # yes, we let gzip figure it out in *any* other case - $me->{UNGZIPPRG} = $CPAN::Config->{gzip} || "gzip"; + $me->{UNGZIPPRG} = _my_which("gzip"); } + $me->{TARPRG} = _my_which("tar") || _my_which("gtar"); bless $me, $class; } +sub _my_which { + my($what) = @_; + if ($CPAN::Config->{$what}) { + return $CPAN::Config->{$what}; + } + if ($CPAN::META->has_inst("File::Which")) { + return File::Which::which($what); + } + my @cand = MM->maybe_command($what); + return $cand[0] if @cand; + require File::Spec; + my $component; + PATH_COMPONENT: foreach $component (File::Spec->path()) { + next unless defined($component) && $component; + my($abs) = File::Spec->catfile($component,$what); + if (MM->maybe_command($abs)) { + return $abs; + } + } + return; +} + sub gzip { my($self,$read) = @_; my $write = $self->{FILE}; @@ -195,18 +214,19 @@ sub DESTROY { undef $self; } - sub untar { my($self) = @_; my $file = $self->{FILE}; my($prefer) = 0; + my $exttar = $self->{TARPRG} || ""; + $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it + my $extgzip = $self->{UNGZIPPRG} || ""; + $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it if (0) { # makes changing order easier } elsif ($BUGHUNTING) { $prefer=2; - } elsif (MM->maybe_command($self->{UNGZIPPRG}) - && - MM->maybe_command($CPAN::Config->{tar})) { + } elsif ($exttar && $extgzip) { # should be default until Archive::Tar handles bzip2 $prefer = 1; } elsif ( @@ -215,9 +235,32 @@ sub untar { $CPAN::META->has_inst("Compress::Zlib") ) { $prefer = 2; } else { + my $foundtar = $exttar ? "'$exttar'" : "nothing"; + my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing"; + my $foundAT; + if ($CPAN::META->has_usable("Archive::Tar")) { + $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION; + } else { + $foundAT = "nothing"; + } + my $foundCZ; + if ($CPAN::META->has_inst("Compress::Zlib")) { + $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION; + } elsif ($foundAT) { + $foundCZ = "nothing"; + } else { + $foundCZ = "also nothing"; + } $CPAN::Frontend->mydie(qq{ -CPAN.pm needs either the external programs tar, gzip and bzip2 -installed. Can't continue. + +CPAN.pm needs either the external programs tar and gzip -or- both +modules Archive::Tar and Compress::Zlib installed. + +For tar I found $foundtar, for gzip $foundzip. + +For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ; + +Can't continue cutting file '$file'. }); } my $tar_verb = "v"; @@ -228,9 +271,9 @@ installed. Can't continue. if ($prefer==1) { # 1 => external gzip+tar my($system); my $is_compressed = $self->gtest(); - my $tarcommand = CPAN::HandleConfig->safe_quote($CPAN::Config->{tar}) || "tar"; + my $tarcommand = CPAN::HandleConfig->safe_quote($exttar); if ($is_compressed) { - my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG}); + my $command = CPAN::HandleConfig->safe_quote($extgzip); $system = qq{$command -dc }. qq{< "$file" | $tarcommand x${tar_verb}f -}; } else { @@ -241,7 +284,7 @@ installed. Can't continue. # pipes if ($is_compressed) { (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//; - $ungzf = File::Basename::basename($ungzf); + $ungzf = basename $ungzf; my $ct = CPAN::Tarzip->new($file); if ($ct->gunzip($ungzf)) { $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n}); @@ -265,6 +308,9 @@ installed. Can't continue. unless ($CPAN::META->has_usable("Archive::Tar")) { $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue"); } + # Make sure AT does not use permissions in the archive + # This leaves it to the user's umask instead + local $Archive::Tar::CHMOD = 0; my $tar = Archive::Tar->new($file,1); my $af; # archive file my @af; diff --git a/lib/CPAN/bin/cpan b/lib/CPAN/bin/cpan index 861d90f..52a1b20 100644 --- a/lib/CPAN/bin/cpan +++ b/lib/CPAN/bin/cpan @@ -338,7 +338,7 @@ sub _create_autobundle CPAN::Shell->autobundle; } -sub _recompile +sub _recompiling { print "Recompiling dynamically-loaded extensions\n"; diff --git a/lib/CPAN/t/02nox.t b/lib/CPAN/t/02nox.t index 90c1b3e..15eae05 100644 --- a/lib/CPAN/t/02nox.t +++ b/lib/CPAN/t/02nox.t @@ -23,7 +23,7 @@ is( $CPAN::Suppress_readline, 1, 'should set suppress readline flag' ); # all of these modules have XS components, should be marked unavailable my $mod; for $mod (qw( Digest::MD5 LWP Compress::Zlib )) { - is( $CPAN::META->has_inst($mod), 0, "$mod should be marked unavailable" ); + is( $CPAN::META->has_inst($mod), 0, "$mod should be marked unavailable" ); } # and these will be set to those in CPAN diff --git a/lib/CPAN/t/03pkgs.t b/lib/CPAN/t/03pkgs.t index 5abb96c..1264bc8 100644 --- a/lib/CPAN/t/03pkgs.t +++ b/lib/CPAN/t/03pkgs.t @@ -6,7 +6,16 @@ use lib "lib"; my @m; if ($ENV{PERL_CORE}){ - @m = ("CPAN", map { "CPAN::$_" } qw(Debug DeferedCode FirstTime Nox Queue Tarzip Version)); + @m = ("CPAN", map { "CPAN::$_" } qw(Debug + DeferedCode + Distroprefs + FirstTime + Kwalify + Nox + Queue + Tarzip + Version + )); } else { opendir DH, "lib/CPAN" or die; @m = ("CPAN", map { "CPAN::$_" } grep { s/\.pm$// } readdir DH); diff --git a/lib/CPAN/t/11mirroredby.t b/lib/CPAN/t/11mirroredby.t index 8d5ee6e..840dfa3 100644 --- a/lib/CPAN/t/11mirroredby.t +++ b/lib/CPAN/t/11mirroredby.t @@ -1,10 +1,10 @@ #!/usr/bin/perl -w BEGIN { - if ($ENV{PERL_CORE}) { - chdir 't' if -d 't'; - unshift @INC, '../lib'; - } + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + } } use strict; @@ -18,12 +18,12 @@ isa_ok( $cmb, 'CPAN::Mirrored::By' ); @$cmb = qw( continent country url ); is( $cmb->continent(), 'continent', - 'continent() should return continent entry' ); + 'continent() should return continent entry' ); is( $cmb->country(), 'country', 'country() should return country entry' ); is( $cmb->url(), 'url', 'url() should return url entry' ); __END__ # Local Variables: # mode: cperl -# cperl-indent-level: 2 +# cperl-indent-level: 4 # End: