X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN.pm;h=1864e0f348fcf0cb7edd522b6565d20fa22e5b79;hb=6a93515622cf0655623a39a9eaff82a4b9b3268b;hp=44923db6c7ac6c42e13df3f88a27ea42f6d284db;hpb=7fefbd4402375aa51661a98e79d837b4c791b26f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/CPAN.pm b/lib/CPAN.pm index 44923db..1864e0f 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,12 +1,13 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- use strict; package CPAN; -$CPAN::VERSION = '1.87_63'; +$CPAN::VERSION = '1.88_53'; $CPAN::VERSION = eval $CPAN::VERSION; use CPAN::HandleConfig; use CPAN::Version; use CPAN::Debug; +use CPAN::Queue; use CPAN::Tarzip; use Carp (); use Config (); @@ -57,10 +58,14 @@ $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; $CPAN::Defaultrecent ||= "http://search.cpan.org/recent"; -use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term +use vars qw($VERSION @EXPORT $AUTOLOAD + $DEBUG $META $HAS_USABLE $term + $GOTOSHELL $Signal $Suppress_readline $Frontend @Defaultsites $Have_warned $Defaultdocs $Defaultrecent - $Be_Silent ); + $Be_Silent + $autoload_recursion + ); @CPAN::ISA = qw(CPAN::Debug Exporter); @@ -89,18 +94,35 @@ use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term sub soft_chdir_with_alternatives ($); -#-> sub CPAN::AUTOLOAD ; -sub AUTOLOAD { - my($l) = $AUTOLOAD; - $l =~ s/.*:://; - my(%EXPORT); - @EXPORT{@EXPORT} = ''; - CPAN::HandleConfig->load unless $CPAN::Config_loaded++; - if (exists $EXPORT{$l}){ - CPAN::Shell->$l(@_); - } else { - die(qq{Unknown CPAN command "$AUTOLOAD". }. - qq{Type ? for help.\n}); +{ + $autoload_recursion ||= 0; + + #-> sub CPAN::AUTOLOAD ; + sub AUTOLOAD { + $autoload_recursion++; + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + if ($CPAN::Signal) { + warn "Refusing to autoload '$l' while signal pending"; + $autoload_recursion--; + return; + } + if ($autoload_recursion > 1) { + my $fullcommand = join " ", map { "'$_'" } $l, @_; + warn "Refusing to autoload $fullcommand in recursion\n"; + $autoload_recursion--; + return; + } + my(%export); + @export{@EXPORT} = ''; + CPAN::HandleConfig->load unless $CPAN::Config_loaded++; + if (exists $export{$l}){ + CPAN::Shell->$l(@_); + } else { + die(qq{Unknown CPAN command "$AUTOLOAD". }. + qq{Type ? for help.\n}); + } + $autoload_recursion--; } } @@ -161,11 +183,10 @@ sub shell { # no strict; # I do not recall why no strict was here (2000-09-03) $META->checklock(); - my @cwd = ( - CPAN::anycwd(), - File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), - File::Spec->rootdir(), - ); + my @cwd = grep { defined $_ and length $_ } + CPAN::anycwd(), + File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), + File::Spec->rootdir(); my $try_detect_readline; $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; my $rl_avail = $Suppress_readline ? "suppressed" : @@ -218,14 +239,10 @@ ReadLine support %s $prompt = $oprompt; } elsif (/./) { my(@line); - if ($] < 5.00322) { # parsewords had a bug until recently - @line = split; - } else { - eval { @line = Text::ParseWords::shellwords($_) }; - warn($@), next SHELLCOMMAND if $@; - warn("Text::Parsewords could not parse the line [$_]"), - next SHELLCOMMAND unless @line; - } + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next SHELLCOMMAND if $@; + warn("Text::Parsewords could not parse the line [$_]"), + next SHELLCOMMAND unless @line; $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; my $command = shift @line; eval { CPAN::Shell->$command(@line) }; @@ -256,37 +273,66 @@ ReadLine support %s require Term::ReadLine; $CPAN::Frontend->myprint("\n$redef subroutines in ". "Term::ReadLine redefined\n"); - @_ = ($oprompt,""); - goto &shell; + $GOTOSHELL = 1; } } - for ($CPAN::Config->{term_ornaments}) { # alias - if (defined $_) { - if (not defined $last_term_ornaments - or $_ != $last_term_ornaments - ) { - local $Term::ReadLine::termcap_nowarn = 1; - $term->ornaments($_); - $last_term_ornaments = $_; + if ($term and $term->can("ornaments")) { + for ($CPAN::Config->{term_ornaments}) { # alias + if (defined $_) { + if (not defined $last_term_ornaments + or $_ != $last_term_ornaments + ) { + local $Term::ReadLine::termcap_nowarn = 1; + $term->ornaments($_); + $last_term_ornaments = $_; + } + } else { + undef $last_term_ornaments; } - } else { - undef $last_term_ornaments; } } + if ($CPAN::DEBUG && $CPAN::DEBUG & $CPAN::DEBUG{CPAN}) { + # debugging 'incommandcolor': should always be off at the end of a command + # (incommandcolor is used to detect recursive dependencies) + for my $class (qw(Module Distribution)) { + for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) { + next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; + CPAN->debug("BUG: $class '$dm' was in command state, resetting"); + delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; + } + } + } + if ($GOTOSHELL) { + $GOTOSHELL = 0; # not too often + $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory"); + @_ = ($oprompt,""); + goto &shell; + } } soft_chdir_with_alternatives(\@cwd); } sub soft_chdir_with_alternatives ($) { my($cwd) = @_; - while (not chdir $cwd->[0]) { - if (@$cwd>1) { - $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! -Trying to chdir to "$cwd->[1]" instead. + unless (@$cwd) { + my $root = File::Spec->rootdir(); + $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to! +Trying '$root' as temporary haven. }); - shift @$cwd; + push @$cwd, $root; + } + while () { + if (chdir $cwd->[0]) { + return; } else { - $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); + if (@$cwd>1) { + $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! +Trying to chdir to "$cwd->[1]" instead. +}); + shift @$cwd; + } else { + $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); + } } } } @@ -447,165 +493,60 @@ sub as_string { package CPAN::Shell; use strict; -use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY); +use vars qw( + $ADVANCED_QUERY + $AUTOLOAD + $COLOR_REGISTERED + $autoload_recursion + $reload + @ISA + ); @CPAN::Shell::ISA = qw(CPAN::Debug); $COLOR_REGISTERED ||= 0; -#-> sub CPAN::Shell::AUTOLOAD ; -sub AUTOLOAD { - my($autoload) = $AUTOLOAD; - my $class = shift(@_); - # warn "autoload[$autoload] class[$class]"; - $autoload =~ s/.*:://; - if ($autoload =~ /^w/) { - if ($CPAN::META->has_inst('CPAN::WAIT')) { - CPAN::WAIT->$autoload(@_); - } else { - $CPAN::Frontend->mywarn(qq{ +{ + # $GLOBAL_AUTOLOAD_RECURSION = 12; + $autoload_recursion ||= 0; + + #-> sub CPAN::Shell::AUTOLOAD ; + sub AUTOLOAD { + $autoload_recursion++; + my($l) = $AUTOLOAD; + my $class = shift(@_); + # warn "autoload[$l] class[$class]"; + $l =~ s/.*:://; + if ($CPAN::Signal) { + warn "Refusing to autoload '$l' while signal pending"; + $autoload_recursion--; + return; + } + if ($autoload_recursion > 1) { + my $fullcommand = join " ", map { "'$_'" } $l, @_; + warn "Refusing to autoload $fullcommand in recursion\n"; + $autoload_recursion--; + return; + } + if ($l =~ /^w/) { + # XXX needs to be reconsidered + if ($CPAN::META->has_inst('CPAN::WAIT')) { + CPAN::WAIT->$l(@_); + } else { + $CPAN::Frontend->mywarn(qq{ Commands starting with "w" require CPAN::WAIT to be installed. Please consider installing CPAN::WAIT to use the fulltext index. For this you just need to type install CPAN::WAIT }); - } - } else { - $CPAN::Frontend->mywarn(qq{Unknown shell command '$autoload @_'. }. - qq{Type ? for help. -}); - } -} - -package CPAN::Queue; -use strict; - -# One use of the queue is to determine if we should or shouldn't -# announce the availability of a new CPAN module - -# Now we try to use it for dependency tracking. For that to happen -# we need to draw a dependency tree and do the leaves first. This can -# easily be reached by running CPAN.pm recursively, but we don't want -# to waste memory and run into deep recursion. So what we can do is -# this: - -# CPAN::Queue is the package where the queue is maintained. Dependencies -# often have high priority and must be brought to the head of the queue, -# possibly by jumping the queue if they are already there. My first code -# attempt tried to be extremely correct. Whenever a module needed -# immediate treatment, I either unshifted it to the front of the queue, -# or, if it was already in the queue, I spliced and let it bypass the -# others. This became a too correct model that made it impossible to put -# an item more than once into the queue. Why would you need that? Well, -# you need temporary duplicates as the manager of the queue is a loop -# that -# -# (1) looks at the first item in the queue without shifting it off -# -# (2) cares for the item -# -# (3) removes the item from the queue, *even if its agenda failed and -# even if the item isn't the first in the queue anymore* (that way -# protecting against never ending queues) -# -# So if an item has prerequisites, the installation fails now, but we -# want to retry later. That's easy if we have it twice in the queue. -# -# I also expect insane dependency situations where an item gets more -# than two lives in the queue. Simplest example is triggered by 'install -# Foo Foo Foo'. People make this kind of mistakes and I don't want to -# get in the way. I wanted the queue manager to be a dumb servant, not -# one that knows everything. -# -# Who would I tell in this model that the user wants to be asked before -# processing? I can't attach that information to the module object, -# because not modules are installed but distributions. So I'd have to -# tell the distribution object that it should ask the user before -# processing. Where would the question be triggered then? Most probably -# in CPAN::Distribution::rematein. -# Hope that makes sense, my head is a bit off:-) -- AK - -use vars qw{ @All }; - -# CPAN::Queue::new ; -sub new { - my($class,$s) = @_; - my $self = bless { qmod => $s }, $class; - push @All, $self; - return $self; -} - -# CPAN::Queue::first ; -sub first { - my $obj = $All[0]; - $obj->{qmod}; -} - -# CPAN::Queue::delete_first ; -sub delete_first { - my($class,$what) = @_; - my $i; - for my $i (0..$#All) { - if ( $All[$i]->{qmod} eq $what ) { - splice @All, $i, 1; - return; - } - } -} - -# CPAN::Queue::jumpqueue ; -sub jumpqueue { - my $class = shift; - my @what = @_; - CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]", - join(",",map {$_->{qmod}} @All), - join(",",@what) - )) if $CPAN::DEBUG; - WHAT: for my $what (reverse @what) { - my $jumped = 0; - for (my $i=0; $i<$#All;$i++) { #prevent deep recursion - CPAN->debug("i[$All[$i]]what[$what]") if $CPAN::DEBUG; - if ($All[$i]->{qmod} eq $what){ - $jumped++; - if ($jumped > 100) { # one's OK if e.g. just - # processing now; more are OK if - # user typed it several times - $CPAN::Frontend->mywarn( -qq{Object [$what] queued more than 100 times, ignoring} - ); - next WHAT; - } } + } else { + $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }. + qq{Type ? for help. +}); } - my $obj = bless { qmod => $what }, $class; - unshift @All, $obj; + $autoload_recursion--; } - CPAN->debug(sprintf("after jumpqueue All[%s] what[%s]", - join(",",map {$_->{qmod}} @All), - join(",",@what) - )) if $CPAN::DEBUG; -} - -# CPAN::Queue::exists ; -sub exists { - my($self,$what) = @_; - my @all = map { $_->{qmod} } @All; - my $exists = grep { $_->{qmod} eq $what } @All; - # warn "in exists what[$what] all[@all] exists[$exists]"; - $exists; -} - -# CPAN::Queue::delete ; -sub delete { - my($self,$mod) = @_; - @All = grep { $_->{qmod} ne $mod } @All; -} - -# CPAN::Queue::nullify_queue ; -sub nullify_queue { - @All = (); } - - package CPAN; use strict; @@ -638,7 +579,6 @@ sub all_objects { CPAN::Index->reload; values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok } -*all = \&all_objects; # Called by shell, not in batch mode. In batch mode I see no risk in # having many processes updating something as installations are @@ -765,15 +705,18 @@ this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your $self->{LOCK} = $lockfile; $fh->close; $SIG{TERM} = sub { - &cleanup; - $CPAN::Frontend->mydie("Got SIGTERM, leaving"); + my $sig = shift; + &cleanup; + $CPAN::Frontend->mydie("Got SIG$sig, leaving"); }; $SIG{INT} = sub { # no blocks!!! - &cleanup if $Signal; - $CPAN::Frontend->mydie("Got another SIGINT") if $Signal; - print "Caught SIGINT\n"; - $Signal++; + my $sig = shift; + &cleanup if $Signal; + die "Got yet another signal" if $Signal > 1; + $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal; + $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n"); + $Signal++; }; # From: Larry Wall @@ -949,7 +892,9 @@ sub has_inst { # it tries again. The second require is only a NOOP returning # 1 if we had success, otherwise it's retrying - $CPAN::Frontend->myprint("CPAN: $mod loaded ok\n"); + my $v = eval "\$$mod\::VERSION"; + $v = $v ? " (v$v)" : ""; + $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n"); if ($mod eq "CPAN::WAIT") { push @CPAN::Shell::ISA, 'CPAN::WAIT'; } @@ -1071,6 +1016,8 @@ sub is_tested { $self->{is_tested}{$what} = 1; } +# unsets the is_tested flag: as soon as the thing is installed, it is +# not needed in set_perl5lib anymore sub is_installed { my($self,$what) = @_; delete $self->{is_tested}{$what}; @@ -1172,7 +1119,6 @@ sub disk_usage { } } else { $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n"); - $CPAN::Frontend->mysleep(2); return; } find( @@ -1287,17 +1233,20 @@ Download, Test, Make, Install... test make test (implies make) readme display these README files install make install (implies test) perldoc display POD documentation +Upgrade + r WORDs or /REGEXP/ or NONE report updates for some/matching/all modules + upgrade WORDs or /REGEXP/ or NONE upgrade some/matching/all modules + Pragmas force COMMAND unconditionally do command notest COMMAND skip testing Other h,? display this menu ! perl-code eval a perl command - r report module updates upgrade upgrade all modules o conf [opt] set and query options q quit the cpan shell reload cpan load CPAN.pm again reload index load newer indices autobundle Snapshot recent latest CPAN uploads}); - } +} } *help = \&h; @@ -1462,8 +1411,8 @@ sub i { # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should -# have been called 'set' and 'o debug' maybe 'set debug' or 'debug' -# 'o conf XXX' calls ->edit in CPAN/HandleConfig.pm +# probably have been called 'set' and 'o debug' maybe 'set debug' or +# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm sub o { my($self,$o_type,@o_what) = @_; $DB::single = 1; @@ -1536,7 +1485,7 @@ sub o { $CPAN::Frontend->myprint("\n\n"); } if ($CPAN::DEBUG) { - $CPAN::Frontend->myprint("Options set for debugging:\n"); + $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n"); my($k,$v); for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) { $v = $CPAN::DEBUG{$k}; @@ -1555,6 +1504,7 @@ Known options: } } +# CPAN::Shell::paintdots_onreload sub paintdots_onreload { my($ref) = shift; sub { @@ -1564,6 +1514,15 @@ sub paintdots_onreload { local($|) = 1; # $CPAN::Frontend->myprint(".($subr)"); $CPAN::Frontend->myprint("."); + if ($subr =~ /\bshell\b/i) { + # warn "debug[$_[0]]"; + + # It would be nice if we could detect that a + # subroutine has actually changed, but for now we + # practically always set the GOTOSHELL global + + $CPAN::GOTOSHELL=1; + } return; } warn @_; @@ -1575,7 +1534,7 @@ sub reload { my($self,$command,@arg) = @_; $command ||= ""; $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG; - if ($command =~ /cpan/i) { + if ($command =~ /^cpan$/i) { my $redef = 0; chdir $CPAN::iCwd if $CPAN::iCwd; # may fail my $failed; @@ -1586,57 +1545,84 @@ sub reload { "CPAN/Tarzip.pm", "CPAN/Debug.pm", "CPAN/Version.pm", + "CPAN/Queue.pm", + "CPAN/Reporter.pm", ); - if ($CPAN::Config->{test_report}) { - push @relo, "CPAN/Reporter.pm"; - } MFILE: for my $f (@relo) { + next unless exists $INC{$f}; + my $p = $f; + $p =~ s/\.pm$//; + $p =~ s|/|::|g; + $CPAN::Frontend->myprint("($p"); local($SIG{__WARN__}) = paintdots_onreload(\$redef); $self->reload_this($f) or $failed++; + my $v = eval "$p\::->VERSION"; + $CPAN::Frontend->myprint("v$v)"); } $CPAN::Frontend->myprint("\n$redef subroutines redefined\n"); - $failed++ unless $redef; if ($failed) { - $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ". + my $errors = $failed == 1 ? "error" : "errors"; + $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ". "this session.\n"); } - } elsif ($command =~ /index/) { + } elsif ($command =~ /^index$/i) { CPAN::Index->force_reload; } else { - $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN.pm file + $CPAN::Frontend->myprint(qq{cpan re-evals the CPAN modules index re-reads the index files\n}); } } +# reload means only load again what we have loaded before +#-> sub CPAN::Shell::reload_this ; sub reload_this { - my($self,$f) = @_; - return 1 unless $INC{$f}; + my($self,$f,$args) = @_; + CPAN->debug("f[$f]") if $CPAN::DEBUG; + return 1 unless $INC{$f}; # we never loaded this, so we do not + # reload but say OK my $pwd = CPAN::anycwd(); - CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'") - if $CPAN::DEBUG; - my $read; + CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG; + my($file); for my $inc (@INC) { - $read = File::Spec->catfile($inc,split /\//, $f); - last if -f $read; - } - unless (-f $read) { - $read = $INC{$f}; - } - unless (-f $read) { + $file = File::Spec->catfile($inc,split /\//, $f); + last if -f $file; + $file = ""; + } + CPAN->debug("file[$file]") if $CPAN::DEBUG; + my @inc = @INC; + unless ($file && -f $file) { + # this thingie is not in the INC path, maybe CPAN/MyConfig.pm? + $file = $INC{$f}; + @inc = substr($file,0,-length($f)); # bring in back to me! + } + CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG; + unless (-f $file) { $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n"); return; } - my $fh = FileHandle->new($read) or - $CPAN::Frontend->mydie("Could not open $read: $!"); - local($/); - local $^W = 1; - my $eval = <$fh>; - CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64))) - if $CPAN::DEBUG; - eval $eval; - if ($@){ - warn $@; - return; + my $mtime = (stat $file)[9]; + $reload->{$f} ||= $^T; + my $must_reload = $mtime > $reload->{$f}; + $args ||= {}; + $must_reload ||= $args->{force}; + if ($must_reload) { + my $fh = FileHandle->new($file) or + $CPAN::Frontend->mydie("Could not open $file: $!"); + local($/); + local $^W = 1; + my $content = <$fh>; + CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128))) + if $CPAN::DEBUG; + delete $INC{$f}; + local @INC = @inc; + eval "require '$f'"; + if ($@){ + warn $@; + return; + } + $reload->{$f} = time; + } else { + $CPAN::Frontend->myprint("__unchanged__"); } return 1; } @@ -1768,8 +1754,8 @@ sub scripts { #-> sub CPAN::Shell::upgrade ; sub upgrade { - my($self) = shift @_; - $self->install($self->r); + my($self,@args) = @_; + $self->install($self->r(@args)); } #-> sub CPAN::Shell::_u_r_common ; @@ -1852,6 +1838,7 @@ sub _u_r_common { } my $color_on = ""; my $color_off = ""; + # $GLOBAL_AUTOLOAD_RECURSION = 12; if ( $COLOR_REGISTERED && @@ -1992,7 +1979,7 @@ sub status { next unless substr($k,0,4) eq "read"; warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024; for my $k2 (sort keys %{$CPAN::META->{$k}}) { - warn sprintf " %-25s %6d %6d\n", + warn sprintf " %-25s %6d (keys: %6d)\n", $k2, Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024, scalar keys %{$CPAN::META->{$k}{$k2}}; @@ -2115,7 +2102,12 @@ sub expand_by_method { next; } for my $method (@$methods) { - if ($obj->$method() =~ /$regex/i) { + my $match = eval {$obj->$method() =~ /$regex/i}; + if ($@) { + my($err) = $@ =~ /^(.+) at .+? line \d+\.$/; + $err ||= $@; # if we were too restrictive above + $CPAN::Frontend->mydie("$err\n"); + } elsif ($match) { push @m, $obj; last; } @@ -2251,65 +2243,19 @@ sub print_ornamented { $swhat =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #}; } - my $line; - my $longest = 0; # Does list::util work on 5.004? - for $line (split /\n/, $swhat) { - $longest = length($line) if length($line) > $longest; - } - $longest = 78 if $longest > 78; # yes, arbitrary, who wants it set-able? if ($self->colorize_output) { + if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) { + # if you want to have this configurable, please file a bugreport + $ornament = "black on_cyan"; + } my $color_on = eval { Term::ANSIColor::color($ornament) } || ""; if ($@) { print "Term::ANSIColor rejects color[$ornament]: $@\n Please choose a different color (Hint: try 'o conf init color.*')\n"; } - my $demobug = 0; # (=0) works, (=1) has some obscure bugs and - # breaks 30shell.t, (=2) has some obvious - # bugs but passes 30shell.t - if ($demobug == 1) { - my $nl = chomp $swhat ? "\n" : ""; - while (length $swhat) { - $line = ""; - if (0) { - $swhat =~ s/(.*\n?)//m; - $line = $1; - last unless $line; - } else { - while (length $swhat) { - my $c = substr($swhat,0,1); - $swhat = substr($swhat,1); - $line .= $c; - if ($c eq "\n") { - last; - } - } - } - - # my($nl) = chomp $line ? "\n" : ""; - # ->debug verboten within print_ornamented ==> recursion! - # warn("line[$line]ornament[$ornament]sprintf[$sprintf]\n") if $CPAN::DEBUG; - print $color_on, - sprintf("%-*s",$longest,$line), - Term::ANSIColor::color("reset"), - $line =~ /\n/ ? "" : $nl; - } - } elsif ($demobug == 2) { - my $block = join "\n", - map { - sprintf("%s%-*s%s", - $color_on, - $longest, - $_, - Term::ANSIColor::color("reset"), - ) - } - split /[\r ]*\n/, $swhat; - print $block; - } else { - print $color_on, - $swhat, - Term::ANSIColor::color("reset"); - } + print $color_on, + $swhat, + Term::ANSIColor::color("reset"); } else { print $swhat; } @@ -2322,7 +2268,7 @@ Please choose a different color (Hint: try 'o conf init color.*')\n"; sub myprint { my($self,$what) = @_; - $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue'); + $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white'); } sub myexit { @@ -2333,13 +2279,13 @@ sub myexit { sub mywarn { my($self,$what) = @_; - $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red'); + $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); } # only to be used for shell commands sub mydie { my($self,$what) = @_; - $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red'); + $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white'); # If it is the shell, we want that the following die to be silent, # but if it is not the shell, we would need a 'die $what'. We need @@ -2353,7 +2299,7 @@ sub mydie { sub colorable_makemaker_prompt { my($foo,$bar) = @_; if (CPAN::Shell->colorize_output) { - my $ornament = $CPAN::Config->{colorize_print}||'bold blue'; + my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; print $color_on; } @@ -2438,9 +2384,10 @@ sub rematein { if (ref $s) { CPAN->debug("s is an object[$s]") if $CPAN::DEBUG; $obj = $s; + } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable } elsif ($s =~ m|^/|) { # looks like a regexp $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ". - "not supported\n"); + "not supported.\nRejecting argument '$s'\n"); $CPAN::Frontend->mysleep(2); next; } elsif ($meth eq "ls") { @@ -2450,9 +2397,10 @@ sub rematein { CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG; $obj = CPAN::Shell->expandany($s); } - if (ref $obj) { + if (0) { + } elsif (ref $obj) { $obj->color_cmd_tmps(0,1); - CPAN::Queue->new($obj->id); + CPAN::Queue->new(qmod => $obj->id, reqtype => "c"); push @qcopy, $obj; } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) { $obj = $CPAN::META->instance('CPAN::Author',uc($s)); @@ -2467,10 +2415,12 @@ sub rematein { ); $CPAN::Frontend->mysleep(2); } - } else { + } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") { + CPAN::InfoObj->dump($s); + } else { $CPAN::Frontend ->mywarn(qq{Warning: Cannot $meth $s, }. - qq{don\'t know what it is. + qq{don't know what it is. Try the command i /$s/ @@ -2484,13 +2434,35 @@ 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 ($s = CPAN::Queue->first) { + while (my $q = CPAN::Queue->first) { my $obj; - if (ref $s) { - $obj = $s; # I do not believe, we would survive if this happened - } else { - $obj = CPAN::Shell->expandany($s); - } + my $s = $q->as_string; + my $reqtype = $q->reqtype || ""; + $obj = CPAN::Shell->expandany($s); + $obj->{reqtype} ||= ""; + CPAN->debug("obj-reqtype[$obj->{reqtype}]". + "q-reqtype[$reqtype]") if $CPAN::DEBUG; + if ($obj->{reqtype}) { + if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) { + $obj->{reqtype} = $reqtype; + if ( + exists $obj->{install} + && + ( + $obj->{install}->can("failed") ? + $obj->{install}->failed : + $obj->{install} =~ /^NO/ + ) + ) { + delete $obj->{install}; + $CPAN::Frontend->mywarn + ("Promoting $obj->{ID} from 'build_requires' to 'requires'"); + } + } + } else { + $obj->{reqtype} = $reqtype; + } + for my $pragma (@pragma) { if ($pragma && @@ -2504,10 +2476,10 @@ to find objects with matching identifiers. if ($]>=5.00303 && $obj->can('called_for')) { $obj->called_for($s); } - CPAN->debug( - qq{pragma[@pragma]meth[$meth]obj[$obj]as_string[$obj->{ID}]} - ) if $CPAN::DEBUG; + CPAN->debug(qq{pragma[@pragma]meth[$meth]}. + qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; + push @qcopy, $obj; if ($obj->$meth()){ CPAN::Queue->delete($s); } else { @@ -3707,8 +3679,8 @@ sub reload { sub reload_x { my($cl,$wanted,$localname,$force) = @_; $force |= 2; # means we're dealing with an index here - CPAN::HandleConfig->load; # we should guarantee loading wherever we rely - # on Config XXX + CPAN::HandleConfig->load; # we should guarantee loading wherever + # we rely on Config XXX $localname ||= $wanted; my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'}, $localname); @@ -3738,6 +3710,8 @@ sub rd_authindex { local($/) = "\n"; local($_); push @lines, split /\012/ while ; + my $i = 0; + my $modulus = int(@lines/75) || 1; foreach (@lines) { my($userid,$fullname,$email) = m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/; @@ -3746,8 +3720,10 @@ sub rd_authindex { # instantiate an author object my $userobj = $CPAN::META->instance('CPAN::Author',$userid); $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email); + $CPAN::Frontend->myprint(".") unless $i++ % $modulus; return if $CPAN::Signal; } + $CPAN::Frontend->myprint("DONE\n"); } sub userid { @@ -3760,18 +3736,19 @@ sub userid { #-> sub CPAN::Index::rd_modpacks ; sub rd_modpacks { my($self, $index_target) = @_; - my @lines; return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); - local($/) = "\n"; local $_; - while ($_ = $fh->READLINE) { - s/\012/\n/g; - my @ls = map {"$_\n"} split /\n/, $_; - unshift @ls, "\n" x length($1) if /^(\n+)/; - push @lines, @ls; - } + CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; + my $slurp = ""; + my $chunk; + while (my $bytes = $fh->READ(\$chunk,8192)) { + $slurp.=$chunk; + } + my @lines = split /\012/, $slurp; + CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG; + undef $fh; # read header my($line_count,$last_updated); while (@lines) { @@ -3780,6 +3757,7 @@ sub rd_modpacks { $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; } + CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG; if (not defined $line_count) { $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header. @@ -3857,8 +3835,9 @@ happen.\a my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; my(%exists); + my $i = 0; + my $modulus = int(@lines/75) || 1; foreach (@lines) { - chomp; # before 1.56 we split into 3 and discarded the rest. From # 1.57 we assign remaining text to $comment thus allowing to # influence isa_perl @@ -3942,20 +3921,21 @@ happen.\a } if ($secondtime) { for my $name ($mod,$dist) { - CPAN->debug("exists name[$name]") if $CPAN::DEBUG; + # $self->debug("exists name[$name]") if $CPAN::DEBUG; $exists{$name} = undef; } } + $CPAN::Frontend->myprint(".") unless $i++ % $modulus; return if $CPAN::Signal; } - undef $fh; + $CPAN::Frontend->myprint("DONE\n"); if ($secondtime) { for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) { for my $o ($CPAN::META->all_objects($class)) { next if exists $exists{$o->{ID}}; $CPAN::META->delete($class,$o->{ID}); - CPAN->debug("deleting ID[$o->{ID}] in class[$class]") - if $CPAN::DEBUG; + # CPAN->debug("deleting ID[$o->{ID}] in class[$class]") + # if $CPAN::DEBUG; } } } @@ -3967,37 +3947,45 @@ sub rd_modlist { return unless defined $index_target; $CPAN::Frontend->myprint("Going to read $index_target\n"); my $fh = CPAN::Tarzip->TIEHANDLE($index_target); - my @eval; - local($/) = "\n"; local $_; - while ($_ = $fh->READLINE) { - s/\012/\n/g; - my @ls = map {"$_\n"} split /\n/, $_; - unshift @ls, "\n" x length($1) if /^(\n+)/; - push @eval, @ls; - } - while (@eval) { - my $shift = shift(@eval); + my $slurp = ""; + my $chunk; + while (my $bytes = $fh->READ(\$chunk,8192)) { + $slurp.=$chunk; + } + my @eval2 = split /\012/, $slurp; + + while (@eval2) { + my $shift = shift(@eval2); if ($shift =~ /^Date:\s+(.*)/){ - return if $DATE_OF_03 eq $1; + if ($DATE_OF_03 eq $1){ + $CPAN::Frontend->myprint("Unchanged.\n"); + return; + } ($DATE_OF_03) = $1; } last if $shift =~ /^\s*$/; } - undef $fh; - push @eval, q{CPAN::Modulelist->data;}; + push @eval2, q{CPAN::Modulelist->data;}; local($^W) = 0; my($comp) = Safe->new("CPAN::Safe1"); - my($eval) = join("", @eval); - my $ret = $comp->reval($eval); + my($eval2) = join("\n", @eval2); + CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG; + my $ret = $comp->reval($eval2); Carp::confess($@) if $@; return if $CPAN::Signal; + my $i = 0; + my $until = keys %$ret; + my $modulus = int($until/75) || 1; + CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG; for (keys %$ret) { my $obj = $CPAN::META->instance("CPAN::Module",$_); delete $ret->{$_}{modid}; # not needed here, maybe elsewhere $obj->set(%{$ret->{$_}}); + $CPAN::Frontend->myprint(".") unless $i++ % $modulus; return if $CPAN::Signal; } + $CPAN::Frontend->myprint("DONE\n"); } #-> sub CPAN::Index::write_metadata_cache ; @@ -4030,7 +4018,7 @@ sub read_metadata_cache { my $cache; eval { $cache = Storable::retrieve($metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? - if (!$cache || ref $cache ne 'HASH'){ + if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){ $LAST_TIME = 0; return; } @@ -4173,7 +4161,8 @@ sub as_glimpse { my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %s\n", $class, $self->{ID}; + my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID}; + push @m, sprintf "%-15s %s\n", $class, $id; join "", @m; } @@ -4235,13 +4224,24 @@ sub fullname { #-> sub CPAN::InfoObj::dump ; sub dump { - my($self) = @_; + my($self, $what) = @_; unless ($CPAN::META->has_inst("Data::Dumper")) { $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); } local $Data::Dumper::Sortkeys; $Data::Dumper::Sortkeys = 1; - $CPAN::Frontend->myprint(Data::Dumper::Dumper($self)); + my $out = Data::Dumper::Dumper($what ? eval $what : $self); + if (length $out > 100000) { + my $fh_pager = FileHandle->new; + local($SIG{PIPE}) = "IGNORE"; + my $pager = $CPAN::Config->{'pager'} || "cat"; + $fh_pager->open("|$pager") + or die "Could not open pager $pager\: $!"; + $fh_pager->print($out); + close $fh_pager; + } else { + $CPAN::Frontend->myprint($out); + } } package CPAN::Author; @@ -4500,6 +4500,7 @@ sub fast_yaml { } } +#-> sub CPAN::Distribution::pretty_id sub pretty_id { my $self = shift; my $id = $self->id; @@ -4524,7 +4525,9 @@ sub color_cmd_tmps { # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1; my $prereq_pm = $self->prereq_pm; if (defined $prereq_pm) { - PREREQ: for my $pre (keys %$prereq_pm) { + PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}}, + keys %{$prereq_pm->{build_requires}||{}}) { + next PREREQ if $pre eq "perl"; my $premo; unless ($premo = CPAN::Shell->expand("Module",$pre)) { $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n"); @@ -5073,7 +5076,7 @@ sub cvs_import { } my $cvs_log = qq{"imported $package $version sources"}; $version =~ s/\./_/g; - # XXX cvs + # XXX cvs: undocumented and unclear how it was meant to work my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log, "$cvs_dir", $userid, "v$version"); @@ -5350,7 +5353,7 @@ sub force { my($self, $method) = @_; for my $att (qw( CHECKSUM_STATUS archived build_dir localfile make install unwrapped - writemakefile modulebuild make_test + writemakefile modulebuild make_test signature_verify )) { delete $self->{$att}; } @@ -5417,7 +5420,6 @@ sub perl { sub make { my($self) = @_; my $make = $self->{modulebuild} ? "Build" : "make"; - $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); # Emergency brake if they said install Pippi and get newest perl if ($self->isa_perl) { if ( @@ -5425,27 +5427,28 @@ sub make { ! $self->{force_update} ) { # if we die here, we break bundles - $CPAN::Frontend->mywarn(sprintf qq{ -The most recent version "%s" of the module "%s" -comes with the current version of perl (%s). -I\'ll build that only if you ask for something like - force install %s -or - install %s + $CPAN::Frontend + ->mywarn(sprintf( + qq{The most recent version "%s" of the module "%s" +is part of the perl-%s distribution. To install that, you need to run + force install %s --or-- + install %s }, - $CPAN::META->instance( - 'CPAN::Module', - $self->called_for - )->cpan_version, - $self->called_for, - $self->isa_perl, - $self->called_for, - $self->id); + $CPAN::META->instance( + 'CPAN::Module', + $self->called_for + )->cpan_version, + $self->called_for, + $self->isa_perl, + $self->called_for, + $self->id, + )); $self->{make} = CPAN::Distrostatus->new("NO isa perl"); $CPAN::Frontend->mysleep(1); return; } } + $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id); $self->get; if ($CPAN::Signal){ delete $self->{force_update}; @@ -5541,35 +5544,55 @@ or local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" }; my($ret,$pid); $@ = ""; + my $go_via_alarm; if ($CPAN::Config->{inactivity_timeout}) { - eval { - alarm $CPAN::Config->{inactivity_timeout}; - local $SIG{CHLD}; # = sub { wait }; - if (defined($pid = fork)) { - if ($pid) { #parent - # wait; - waitpid $pid, 0; - } else { #child + require Config; + if ($Config::Config{d_alarm} + && + $Config::Config{d_alarm} eq "define" + ) { + $go_via_alarm++ + } else { + $CPAN::Frontend->mywarn("Warning: you have configured the config ". + "variable 'inactivity_timeout' to ". + "'$CPAN::Config->{inactivity_timeout}'. But ". + "on this machine the system call 'alarm' ". + "isn't available. This means that we cannot ". + "provide the feature of intercepting long ". + "waiting code and will turn this feature off.\n" + ); + $CPAN::Config->{inactivity_timeout} = 0; + } + } + if ($go_via_alarm) { + eval { + alarm $CPAN::Config->{inactivity_timeout}; + local $SIG{CHLD}; # = sub { wait }; + if (defined($pid = fork)) { + if ($pid) { #parent + # wait; + waitpid $pid, 0; + } else { #child # note, this exec isn't necessary if # inactivity_timeout is 0. On the Mac I'd # suggest, we set it always to 0. exec $system; - } - } else { - $CPAN::Frontend->myprint("Cannot fork: $!"); - return; - } - }; - alarm 0; - if ($@){ - kill 9, $pid; - waitpid $pid, 0; + } + } else { + $CPAN::Frontend->myprint("Cannot fork: $!"); + return; + } + }; + alarm 0; + if ($@){ + kill 9, $pid; + waitpid $pid, 0; my $err = "$@"; - $CPAN::Frontend->myprint($err); - $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); - $@ = ""; - return; - } + $CPAN::Frontend->myprint($err); + $self->{writemakefile} = CPAN::Distrostatus->new("NO $err"); + $@ = ""; + return; + } } else { $ret = system($system); if ($ret != 0) { @@ -5592,7 +5615,15 @@ or return; } if (my @prereq = $self->unsat_prereq){ - return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + 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"); + return; + } else { + return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + } } if ($self->{modulebuild}) { unless (-f "Build") { @@ -5634,15 +5665,20 @@ sub _make_command { #-> sub CPAN::Distribution::follow_prereqs ; sub follow_prereqs { my($self) = shift; - my(@prereq) = grep {$_ ne "perl"} @_; - return unless @prereq; + my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_; + return unless @prereq_tuples; + my @prereq = map { $_->[0] } @prereq_tuples; my $id = $self->id; - $CPAN::Frontend->myprint("---- Unsatisfied dependencies detected ". - "during [$id] -----\n"); - - for my $p (@prereq) { - $CPAN::Frontend->myprint(" $p\n"); - } + my %map = ( + b => "build_requires", + r => "requires", + c => "commandline", + ); + $CPAN::Frontend-> + myprint("---- Unsatisfied dependencies detected during\n". + "---- $id\n". + join("", map {" $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples), + ); my $follow = 0; if ($CPAN::Config->{prerequisites_policy} eq "follow") { $follow = 1; @@ -5662,33 +5698,46 @@ of modules we are processing right now?", "yes"); # warn "calling color_cmd_tmps(0,1)"; CPAN::Shell->expandany($p)->color_cmd_tmps(0,1); } - CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself + # queue them and re-queue yourself + CPAN::Queue->jumpqueue([$id,$self->{reqtype}], + reverse @prereq_tuples); $self->{later} = "Delayed until after prerequisites"; return 1; # signal success to the queuerunner } } #-> sub CPAN::Distribution::unsat_prereq ; +# return ([Foo=>1],[Bar=>1.2]) for normal modules +# return ([perl=>5.008]) if we need a newer perl than we are running under sub unsat_prereq { my($self) = @_; my $prereq_pm = $self->prereq_pm or return; my(@need); - NEED: while (my($need_module, $need_version) = each %$prereq_pm) { - my $nmo = $CPAN::META->instance("CPAN::Module",$need_module); - # we were too demanding: - next if $nmo->uptodate; - - # if they have not specified a version, we accept any installed one - if (not defined $need_version or - $need_version eq "0" or - $need_version eq "undef") { - next if defined $nmo->inst_file; + my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}}); + NEED: while (my($need_module, $need_version) = each %merged) { + my($have_version,$inst_file); + if ($need_module eq "perl") { + $have_version = $]; + $inst_file = $^X; + } else { + my $nmo = $CPAN::META->instance("CPAN::Module",$need_module); + next if $nmo->uptodate; + $inst_file = $nmo->inst_file; + + # if they have not specified a version, we accept any installed one + if (not defined $need_version or + $need_version eq "0" or + $need_version eq "undef") { + next if defined $inst_file; + } + + $have_version = $nmo->inst_version; } # We only want to install prereqs if either they're not installed # or if the installed version is too old. We cannot omit this # check, because if 'force' is in effect, nobody else will check. - if (defined $nmo->inst_file) { + if (defined $inst_file) { my(@all_requirements) = split /\s*,\s*/, $need_version; local($^W) = 0; my $ok = 0; @@ -5696,13 +5745,13 @@ sub unsat_prereq { if ($rq =~ s|>=\s*||) { } elsif ($rq =~ s|>\s*||) { # 2005-12: one user - if (CPAN::Version->vgt($nmo->inst_version,$rq)){ + if (CPAN::Version->vgt($have_version,$rq)){ $ok++; } next RQ; } elsif ($rq =~ s|!=\s*||) { # 2005-12: no user - if (CPAN::Version->vcmp($nmo->inst_version,$rq)){ + if (CPAN::Version->vcmp($have_version,$rq)){ $ok++; next RQ; } else { @@ -5714,27 +5763,32 @@ sub unsat_prereq { $ok++; next RQ; } - if (! CPAN::Version->vgt($rq, $nmo->inst_version)){ + if (! CPAN::Version->vgt($rq, $have_version)){ $ok++; } - CPAN->debug(sprintf "id[%s]inst_file[%s]inst_version[%s]rq[%s]ok[%d]", - $nmo->id, - $nmo->inst_file, - $nmo->inst_version, - CPAN::Version->readable($rq), - $ok, - ) if $CPAN::DEBUG; + CPAN->debug(sprintf("need_module[%s]inst_file[%s]". + "inst_version[%s]rq[%s]ok[%d]", + $need_module, + $inst_file, + $have_version, + CPAN::Version->readable($rq), + $ok, + )) if $CPAN::DEBUG; } next NEED if $ok == @all_requirements; } + if ($need_module eq "perl") { + return ["perl", $need_version]; + } if ($self->{sponsored_mods}{$need_module}++){ # We have already sponsored it and for some reason it's still # not available. So we do nothing. Or what should we do? # if we push it again, we have a potential infinite loop next; } - push @need, $need_module; + my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b"; + push @need, [$need_module,$needed_as]; } @need; } @@ -5759,7 +5813,8 @@ sub read_yaml { $self->{yaml_content} = undef; } } - $self->debug("yaml_content[$self->{yaml_content}]") if $CPAN::DEBUG; + $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF") + if $CPAN::DEBUG; return $self->{yaml_content}; } @@ -5771,9 +5826,10 @@ sub prereq_pm { return unless $self->{writemakefile} # no need to have succeeded # but we must have run it || $self->{modulebuild}; - my $req; - if (my $yaml = $self->read_yaml) { - $req = $yaml->{requires}; + my($req,$breq); + if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here + $req = $yaml->{requires} || {}; + $breq = $yaml->{build_requires} || {}; undef $req unless ref $req eq "HASH" && %$req; if ($req) { if ($yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { @@ -5805,22 +5861,8 @@ sub prereq_pm { } $req = $areq if $do_replace; } - if ($yaml->{build_requires} - && ref $yaml->{build_requires} - && ref $yaml->{build_requires} eq "HASH") { - while (my($k,$v) = each %{$yaml->{build_requires}}) { - if ($req->{$k}) { - # merging of two "requires"-type values--what should we do? - } else { - $req->{$k} = $v; - } - } - } - if ($req) { - delete $req->{perl}; - } } - unless ($req) { + unless ($req || $breq) { my $build_dir = $self->{build_dir} or die "Panic: no build_dir?"; my $makefile = File::Spec->catfile($build_dir,"Makefile"); my $fh; @@ -5850,23 +5892,41 @@ sub prereq_pm { } } elsif (-f "Build") { if ($CPAN::META->has_inst("Module::Build")) { - my $requires = Module::Build->current->requires(); - my $brequires = Module::Build->current->build_requires(); - $req = { %$requires, %$brequires }; + eval { + $req = Module::Build->current->requires(); + $breq = Module::Build->current->build_requires(); + }; + if ($@) { + # HTML::Mason prompted for this with bleadperl@28900 or so + $CPAN::Frontend + ->mywarn( + sprintf("Warning: while trying to determine ". + "prerequisites for %s with the help of ". + "Module::Build the following error ". + "occurred: '%s'\n\nCannot care for prerequisites\n", + $self->id, + $@ + )); + $self->{prereq_pm_detected}++; + return $self->{prereq_pm} = {requires=>{},build_requires=>{}}; + } } } } - if (-f "Build.PL" && ! -f "Makefile.PL" && ! exists $req->{"Module::Build"}) { + if (-f "Build.PL" + && ! -f "Makefile.PL" + && ! exists $req->{"Module::Build"} + && ! $CPAN::META->has_inst("Module::Build")) { $CPAN::Frontend->mywarn(" Warning: CPAN.pm discovered Module::Build as ". "undeclared prerequisite.\n". - " Adding it now as a prerequisite.\n" + " Adding it now as such.\n" ); $CPAN::Frontend->mysleep(5); $req->{"Module::Build"} = 0; delete $self->{writemakefile}; } $self->{prereq_pm_detected}++; - return $self->{prereq_pm} = $req; + return $self->{prereq_pm} = { requires => $req, build_requires => $breq }; } #-> sub CPAN::Distribution::test ; @@ -5886,7 +5946,9 @@ sub test { my $make = $self->{modulebuild} ? "Build" : "make"; $CPAN::Frontend->myprint("Running $make test\n"); if (my @prereq = $self->unsat_prereq){ - return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + unless ($prereq[0][0] eq "perl") { + return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner + } } EXCUSE: { my @e; @@ -5902,7 +5964,6 @@ sub test { $self->{make} =~ /^NO/ ) and push @e, "Can't test without successful make"; - exists $self->{build_dir} or push @e, "Has no own directory"; $self->{badtestcnt} ||= 0; $self->{badtestcnt} > 0 and push @e, "Won't repeat unsuccessful test during this command"; @@ -5910,6 +5971,23 @@ sub test { exists $self->{later} and length($self->{later}) and push @e, $self->{later}; + if (exists $self->{build_dir}) { + if ($CPAN::META->{is_tested}{$self->{build_dir}} + && + exists $self->{make_test} + && + !( + $self->{make_test}->can("failed") ? + $self->{make_test}->failed : + $self->{make_test} =~ /^NO/ + ) + ) { + push @e, "Already tested successfully"; + } + } elsif (!@e) { + push @e, "Has no own directory"; + } + $CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e; } chdir $self->{'build_dir'} or @@ -5922,6 +6000,16 @@ sub test { return; } + if ($self->{modulebuild}) { + my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version; + if (CPAN::Version->vlt($v,2.62)) { + $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; + } + } + local $ENV{PERL5LIB} = defined($ENV{PERL5LIB}) ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); @@ -5938,18 +6026,40 @@ sub test { my $tests_ok; if ( $CPAN::Config->{test_report} && $CPAN::META->has_inst("CPAN::Reporter") ) { - $tests_ok = CPAN::Reporter::test($self, $system); + $tests_ok = CPAN::Reporter::test($self, $system); } else { - $tests_ok = system($system) == 0; + $tests_ok = system($system) == 0; } if ( $tests_ok ) { - $CPAN::Frontend->myprint(" $system -- OK\n"); - $CPAN::META->is_tested($self->{'build_dir'}); - $self->{make_test} = CPAN::Distrostatus->new("YES"); + { + my @prereq; + for my $m (keys %{$self->{sponsored_mods}}) { + my $m_obj = CPAN::Shell->expand("Module",$m); + if (!$m_obj->distribution->{make_test} + || + $m_obj->distribution->{make_test}->failed){ + #$m_obj->dump; + push @prereq, $m; + } + } + if (@prereq){ + my $cnt = @prereq; + my $which = join ",", @prereq; + my $verb = $cnt == 1 ? "one dependency not OK ($which)" : + "$cnt dependencies missing ($which)"; + $CPAN::Frontend->mywarn("Tests succeeded but $verb\n"); + $self->{make_test} = CPAN::Distrostatus->new("NO -- $verb"); + return; + } + } + + $CPAN::Frontend->myprint(" $system -- OK\n"); + $CPAN::META->is_tested($self->{'build_dir'}); + $self->{make_test} = CPAN::Distrostatus->new("YES"); } else { - $self->{make_test} = CPAN::Distrostatus->new("NO"); - $self->{badtestcnt}++; - $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + $self->{make_test} = CPAN::Distrostatus->new("NO"); + $self->{badtestcnt}++; + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); } } @@ -6039,8 +6149,6 @@ sub install { $CPAN::Frontend->myprint("Running $make install\n"); EXCUSE: { my @e; - exists $self->{build_dir} or push @e, "Has no own directory"; - unless (exists $self->{make} or exists $self->{later}) { push @e, "Make had some problems, won't install"; @@ -6052,7 +6160,12 @@ sub install { $self->{make}->failed : $self->{make} =~ /^NO/ ) and - push @e, "make had returned bad status, install seems impossible"; + push @e, "Make had returned bad status, install seems impossible"; + + if (exists $self->{build_dir}) { + } elsif (!@e) { + push @e, "Has no own directory"; + } if (exists $self->{make_test} and ( @@ -6116,6 +6229,30 @@ sub install { } my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 "; + $CPAN::Config->{build_requires_install_policy}||="ask/yes"; + my $id = $self->id; + my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command + my $want_install = "yes"; + if ($reqtype eq "b") { + if ($CPAN::Config->{build_requires_install_policy} eq "no") { + $want_install = "no"; + } elsif ($CPAN::Config->{build_requires_install_policy} =~ m|^ask/(.+)|) { + my $default = $1; + $default = "yes" unless $default =~ /^(y|n)/i; + $want_install = + CPAN::Shell::colorable_makemaker_prompt + ("$id is just needed temporarily during building or testing. ". + "Do you want to install it permanently? (Y/n)", + $default); + } + } + unless ($want_install =~ /^y/i) { + my $is_only = "is only 'build_requires'"; + $CPAN::Frontend->mywarn("Not installing because $is_only\n"); + $self->{install} = CPAN::Distrostatus->new("NO -- $is_only"); + delete $self->{force_update}; + return; + } my($pipe) = FileHandle->new("$system $stderr |"); my($makeout) = ""; while (<$pipe>){ @@ -6268,9 +6405,9 @@ saved output to %s\n}, my $fh_pager = FileHandle->new; local($SIG{PIPE}) = "IGNORE"; my $pager = $CPAN::Config->{'pager'} || "cat"; - $fh_pager->open("|pager") + $fh_pager->open("|$pager") or $CPAN::Frontend->mydie(qq{ -Could not open pager $pager\: $!}); +Could not open pager '$pager': $!}); $CPAN::Frontend->myprint(qq{ Displaying URL $url @@ -6356,7 +6493,6 @@ sub _build_command { if ($^O eq "MSWin32") { # special code needed at least up to # Module::Build 0.2611 and 0.2706; a fix # in M:B has been promised 2006-01-30 - my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n"); return "$perl ./Build"; } @@ -6575,6 +6711,7 @@ explicitly a file $s. # possibly noisy action: $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; my $obj = $CPAN::META->instance($type,$s); + $obj->{reqtype} = $self->{reqtype}; $obj->$meth(); if ($obj->isa('CPAN::Bundle') && @@ -7029,7 +7166,7 @@ sub notest { #-> sub CPAN::Module::rematein ; sub rematein { my($self,$meth) = @_; - $CPAN::Frontend->myprint(sprintf("Running %s for module %s\n", + $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n", $meth, $self->id)); my $cpan_file = $self->cpan_file; @@ -7050,6 +7187,31 @@ sub rematein { $pack->called_for($self->id); $pack->force($meth) if exists $self->{'force_update'}; $pack->notest($meth) if exists $self->{'notest'}; + + $pack->{reqtype} ||= ""; + CPAN->debug("dist-reqtype[$pack->{reqtype}]". + "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG; + if ($pack->{reqtype}) { + if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) { + $pack->{reqtype} = $self->{reqtype}; + if ( + exists $pack->{install} + && + ( + $pack->{install}->can("failed") ? + $pack->{install}->failed : + $pack->{install} =~ /^NO/ + ) + ) { + delete $pack->{install}; + $CPAN::Frontend->mywarn + ("Promoting $pack->{ID} from 'build_requires' to 'requires'"); + } + } + } else { + $pack->{reqtype} = $self->{reqtype}; + } + eval { $pack->$meth(); }; @@ -7244,14 +7406,8 @@ Batch mode: =head1 STATUS -This module will eventually be replaced by CPANPLUS. CPANPLUS is kind -of a modern rewrite from ground up with greater extensibility and more -features but no full compatibility. If you're new to CPAN.pm, you -probably should investigate if CPANPLUS is the better choice for you. - -If you're already used to CPAN.pm you're welcome to continue using it. -I intend to support it until somebody convinces me that there is a -both superior and sufficiently compatible drop-in replacement. +This module and its competitor, the CPANPLUS module, are both much +cooler than the other. =head1 COMPATIBILITY @@ -7291,7 +7447,7 @@ mechanism. All methods provided are accessible in a programmer style and in an interactive shell style. -=head2 Interactive Mode +=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode The interactive mode is entered by running @@ -7485,10 +7641,11 @@ perl breaks binary compatibility. If one of the modules that CPAN uses is in turn depending on binary compatibility (so you cannot run CPAN commands), then you should try the CPAN::Nox module for recovery. -=head2 upgrade +=head2 upgrade [Module|/Regex/]... -The C command first runs an C command and then installs -the newest versions of all modules that were listed by that. +The C command first runs an C command with the given +arguments and then installs the newest versions of all modules that +were listed by that. =head2 mkmyconfig @@ -7535,7 +7692,7 @@ so you would have to say The first example will be driven by an object of the class CPAN::Module, the second by an object of class CPAN::Distribution. -=head2 Programmer's interface +=head1 PROGRAMMER'S INTERFACE If you do not enter the shell, the available shell commands are both available as methods (Cinstall(...)>) and as @@ -8063,7 +8220,7 @@ your @INC path. The autobundle() command which is available in the shell interface does that for you by including all currently installed modules in a snapshot bundle file. -=head2 Prerequisites +=head1 PREREQUISITES If you have a local mirror of CPAN and can access all files with "file:" URLs, then you only need a perl better than perl5.003 to run @@ -8075,6 +8232,8 @@ If you have neither Net::FTP nor LWP, there is a fallback mechanism implemented for an external ftp command or for an external lynx command. +=head1 UTILITIES + =head2 Finding packages and VERSION This module presumes that all packages on CPAN @@ -8110,13 +8269,45 @@ interferences of the software producing the indices on CPAN, of the mirroring process on CPAN, of packaging, of configuration, of synchronicity, and of bugs within CPAN.pm. -For code debugging in interactive mode you can try "o debug" which -will list options for debugging the various parts of the code. You -should know that "o debug" has built-in completion support. +For debugging the code of CPAN.pm itself in interactive mode some more +or less useful debugging aid can be turned on for most packages within +CPAN.pm with one of + +=over 2 + +=item o debug package... + +sets debug mode for packages. + +=item o debug -package... + +unsets debug mode for packages. -For data debugging there is the C command which takes the same -arguments as make/test/install and outputs the object's Data::Dumper -dump. +=item o debug all + +turns debugging on for all packages. + +=item o debug number + +=back + +which sets the debugging packages directly. Note that C +turns debugging off. + +What seems quite a successful strategy is the combination of C and the debugging switches. Add a new debug statement while +running in the shell and then issue a C and see the new +debugging messages immediately without losing the current context. + +C without an argument lists the valid package names and the +current set of packages in debugging mode. C has built-in +completion support. + +For debugging of CPAN data there is the C command which takes +the same arguments as make/test/install and outputs each object's +Data::Dumper dump. If an argument looks like a perl variable and +contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to +Data::Dumper directly. =head2 Floppy, Zip, Offline Mode @@ -8129,6 +8320,28 @@ $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind of a personal CPAN. CPAN.pm on the non-networked machines works nicely with this floppy. See also below the paragraph about CD-ROM support. +=head2 Basic Utilities for Programmers + +=over 2 + +=item has_inst($module) + +Returns true if the module is installed. See the source for details. + +=item has_usable($module) + +Returns true if the module is installed and several and is in a usable +state. Only useful for a handful of modules that are used internally. +See the source for details. + +=item instance($module) + +The constructor for all the singletons used to represent modules, +distributions, authors and bundles. If the object already exists, this +method returns the object, otherwise it calls the constructor. + +=back + =head1 CONFIGURATION When the CPAN module is used for the first time, a configuration @@ -8152,19 +8365,35 @@ defined: build_cache size of cache for directories to build modules build_dir locally accessible directory to build modules + build_requires_install_policy + to install or not to install: when a module is + 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_output boolean if Term::ANSIColor should colorize output + colorize_print Term::ANSIColor attributes for normal output + colorize_warn Term::ANSIColor attributes for warnings + commandnumber_in_prompt + boolean if you want to see current command number cpan_home local directory reserved for this package + curl path to external prg + dontload_hash DEPRECATED dontload_list arrayref: modules in the list will not be loaded by the CPAN::has_inst() routine + ftp path to external prg + ftp_passive if set, the envariable FTP_PASSIVE is set for downloads + ftp_proxy proxy host for ftp requests getcwd see below + gpg path to external prg gzip location of external program gzip histfile file to maintain history between sessions histsize maximum number of lines to keep in histfile + http_proxy proxy host for http requests inactivity_timeout breaks interactive Makefile.PLs or Build.PLs after this many seconds inactivity. Set to 0 to never break. @@ -8172,6 +8401,7 @@ defined: inhibit_startup_message if true, does not print the startup message keep_source_where directory in which to keep the source (if we do) + lynx path to external prg make location of external make program make_arg arguments that should always be passed to 'make' make_install_make_command @@ -8185,7 +8415,11 @@ defined: command to use instead of './Build' when we are in the install stage, for example 'sudo ./Build' mbuildpl_arg arguments passed to 'perl Build.PL' + ncftp path to external prg + ncftpget path to external prg + no_proxy don't proxy to these hosts/domains (comma separated list) pager location of external program more (or any pager) + password your password if you CPAN server wants one 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 @@ -8197,17 +8431,18 @@ defined: proxy_user username for accessing an authenticating proxy proxy_pass password for accessing an authenticating proxy scan_cache controls scanning of cache ('atstart' or 'never') + shell your favorite shell + show_upload_date boolean if commands should try to determine upload date tar location of external program tar term_is_latin if true internal UTF-8 is translated to ISO-8859-1 (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) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) + username your username if you CPAN server wants one wait_list arrayref to a wait server to try (See CPAN::WAIT) - ftp_passive if set, the envariable FTP_PASSIVE is set for downloads - ftp_proxy, } the three usual variables for configuring - http_proxy, } proxy requests. Both as CPAN::Config variables - no_proxy } and as environment variables configurable. + wget path to external prg You can set and query each of these options interactively in the cpan shell with the command set defined within the C command: @@ -8237,17 +8472,32 @@ works like the corresponding perl commands. =back -=head2 Note on config variable getcwd +=head2 CPAN::anycwd($path): Note on config variable getcwd CPAN.pm changes the current working directory often and needs to determine its own current working directory. Per default it uses Cwd::cwd but if this doesn't work on your system for some reason, alternatives can be configured according to the following table: - cwd Cwd::cwd - getcwd Cwd::getcwd - fastcwd Cwd::fastcwd - backtickcwd external command cwd +=over 2 + +=item cwd + +Calls Cwd::cwd + +=item getcwd + +Calls Cwd::getcwd + +=item fastcwd + +Calls Cwd::fastcwd + +=item backtickcwd + +Calls the external command cwd. + +=back =head2 Note on urllist parameter's format @@ -8701,6 +8951,13 @@ unusable. Please consider backing up your data before every upgrade. Andreas Koenig C<< >> +=head1 LICENSE + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L + =head1 TRANSLATIONS Kawai,Takanori provides a Japanese translation of this manpage at