# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-package CPAN;
-$VERSION = '1.87_55';
-$VERSION = eval $VERSION;
use strict;
+package CPAN;
+$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 ();
use Sys::Hostname qw(hostname);
use Text::ParseWords ();
use Text::Wrap ();
-no lib "."; # we need to run chdir all over and we would get at wrong
- # libraries there
+
+# 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);
+ }
+ }
+}
+no lib ".";
require Mac::BuildTools if $^O eq 'MacOS';
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
-@CPAN::Defaultsites = ("http://www.perl.org/CPAN/","ftp://ftp.perl.org/pub/CPAN/")
- unless @CPAN::Defaultsites;
+unless (@CPAN::Defaultsites){
+ @CPAN::Defaultsites = map {
+ CPAN::URL->new(TEXT => $_, FROM => "DEF")
+ }
+ "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::Perl ||= CPAN::find_perl();
$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);
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--;
}
}
}
close $fh;
}}
- # $term->OUT is autoflushed anyway
- for ($CPAN::Config->{term_ornaments}) {
+ for ($CPAN::Config->{term_ornaments}) { # alias
+ local $Term::ReadLine::termcap_nowarn = 1;
$term->ornaments($_) if defined;
}
+ # $term->OUT is autoflushed anyway
my $odef = select STDERR;
$| = 1;
select STDOUT;
# 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" :
($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
"available (try 'install Bundle::CPAN')";
- $CPAN::Frontend->myprint(
- sprintf qq{
+ unless ($CPAN::Config->{'inhibit_startup_message'}){
+ $CPAN::Frontend->myprint(
+ sprintf qq{
cpan shell -- CPAN exploration and modules installation (v%s)
ReadLine support %s
},
- $CPAN::VERSION,
- $rl_avail
- )
- unless $CPAN::Config->{'inhibit_startup_message'} ;
+ $CPAN::VERSION,
+ $rl_avail
+ )
+ }
my($continuation) = "";
+ my $last_term_ornaments;
SHELLCOMMAND: while () {
if ($Suppress_readline) {
print $prompt;
$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) };
require Term::ReadLine;
$CPAN::Frontend->myprint("\n$redef subroutines in ".
"Term::ReadLine redefined\n");
- @_ = ($oprompt,"");
- goto &shell;
+ $GOTOSHELL = 1;
}
}
+ 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;
+ }
+ }
+ }
+ 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]": $!});
+ }
}
}
}
}
}
+package CPAN::URL; use overload '""' => "as_string", fallback => 1;
+# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
+# planned are things like age or quality
+sub new {
+ my($class,%args) = @_;
+ bless {
+ %args
+ }, $class;
+}
+sub as_string {
+ my($self) = @_;
+ $self->text;
+}
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+
package CPAN::Distrostatus;
use overload '""' => "as_string",
fallback => 1;
package CPAN::Shell;
use strict;
-use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
+use vars qw(
+ $ADVANCED_QUERY
+ $AUTOLOAD
+ $COLOR_REGISTERED
+ $autoload_recursion
+ $reload
+ @ISA
+ );
@CPAN::Shell::ISA = qw(CPAN::Debug);
$COLOR_REGISTERED ||= 0;
-$PRINT_ORNAMENTING ||= 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;
SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
$CPAN::Frontend->myprint("You don't seem to have a user ".
"configuration (MyConfig.pm) yet.\n");
- my $new = ExtUtils::MakeMaker::prompt("Do you want to create a ".
+ my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
"user configuration now? (Y/n)",
"yes");
if($new =~ m{^y}i) {
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
});
} elsif (-w $lockfile) {
my($ans) =
- ExtUtils::MakeMaker::prompt
+ CPAN::Shell::colorable_makemaker_prompt
(qq{Other job not responding. Shall I overwrite }.
qq{the lockfile '$lockfile'? (Y/n)},"y");
$CPAN::Frontend->myexit("Ok, bye\n")
$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 <larry@wall.org>
# 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';
}
install Bundle::libnet
}) unless $Have_warned->{"Net::FTP"}++;
- sleep 3;
+ $CPAN::Frontend->mysleep(3);
} elsif ($mod eq "Digest::SHA"){
if ($Have_warned->{"Digest::SHA"}++) {
$CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
qq{because Digest::SHA not installed.\n});
} else {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
CPAN: checksum security checks disabled because Digest::SHA not installed.
Please consider installing the Digest::SHA module.
});
- sleep 2;
+ $CPAN::Frontend->mysleep(2);
}
} elsif ($mod eq "Module::Signature"){
if (not $CPAN::Config->{check_sigs}) {
$CPAN::Config->{'gpg'} =~ /\S/
)
) {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
CPAN: Module::Signature security checks disabled because Module::Signature
not installed. Please consider installing the Module::Signature module.
You may also need to be able to connect over the Internet to the public
keyservers like pgp.mit.edu (port 11371).
});
- sleep 2;
+ $CPAN::Frontend->mysleep(2);
}
}
} else {
unlink $META->{LOCK};
# require Carp;
# Carp::cluck("DEBUGGING");
- $CPAN::Frontend->mywarn("Lockfile removed.\n");
+ $CPAN::Frontend->myprint("Lockfile removed.\n");
}
#-> sub CPAN::savehist
$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};
}
} else {
$CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
- $CPAN::Frontend->mysleep(2);
return;
}
find(
"the permission to change the permission; ".
"can only partially estimate disk usage ".
"of '$_'\n");
- sleep 5;
+ $CPAN::Frontend->mysleep(5);
return;
}
}
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;
#-> sub CPAN::Shell::o ;
-# CPAN::Shell::o and CPAN::Config::edit are closely related. 'o conf'
-# should have been called set and 'o debug' maybe 'set debug'
+# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
+# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
+# 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;
$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};
}
}
+# CPAN::Shell::paintdots_onreload
sub paintdots_onreload {
my($ref) = shift;
sub {
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 @_;
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;
- MFILE: for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
- CPAN/Debug.pm CPAN/Version.pm)) {
+ my @relo = (
+ "CPAN.pm",
+ "CPAN/HandleConfig.pm",
+ "CPAN/FirstTime.pm",
+ "CPAN/Tarzip.pm",
+ "CPAN/Debug.pm",
+ "CPAN/Version.pm",
+ "CPAN/Queue.pm",
+ "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;
}
my($self, $arg) = @_;
$CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
- require HTML::LinkExtor;
- require Sort::Versions;
- require List::Util;
+ for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
+ unless ($CPAN::META->has_inst($req)) {
+ $CPAN::Frontend->mywarn(" $req not available\n");
+ }
+ }
my $p = HTML::LinkExtor->new();
my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
unless (-f $indexfile) {
my @hrefs;
my $qrarg;
if ($arg =~ s|^/(.+)/$|$1|) {
- $qrarg = qr/$arg/;
+ $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
}
for my $l ($p->links) {
my $tag = shift @$l;
#-> 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 ;
}
my $color_on = "";
my $color_off = "";
+ # $GLOBAL_AUTOLOAD_RECURSION = 12;
if (
$COLOR_REGISTERED
&&
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}};
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;
}
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)
-#-> sub CPAN::Shell::print_ornameted ;
+# to turn colordebugging on, write
+# cpan> o conf colorize_output 1
+
+#-> sub CPAN::Shell::print_ornamented ;
+{
+ my $print_ornamented_have_warned = 0;
+ sub colorize_output {
+ my $colorize_output = $CPAN::Config->{colorize_output};
+ if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
+ unless ($print_ornamented_have_warned++) {
+ # no myprint/mywarn within myprint/mywarn!
+ warn "Colorize_output is set to true but Term::ANSIColor is not
+installed. To activate colorized output, please install Term::ANSIColor.\n\n";
+ }
+ $colorize_output = 0;
+ }
+ return $colorize_output;
+ }
+}
+
+
sub print_ornamented {
my($self,$what,$ornament) = @_;
- my $longest = 0;
return unless defined $what;
local $| = 1; # Flush immediately
print {report_fh()} $what;
return;
}
-
+ my $swhat = "$what"; # stringify if it is an object
if ($CPAN::Config->{term_is_latin}){
# courtesy jhi:
- $what
+ $swhat
=~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
}
- if ($PRINT_ORNAMENTING) {
- unless (defined &color) {
- if ($CPAN::META->has_inst("Term::ANSIColor")) {
- import Term::ANSIColor "color";
- } else {
- *color = sub { return "" };
- }
- }
- my $line;
- for $line (split /\n/, $what) {
- $longest = length($line) if length($line) > $longest;
- }
- my $sprintf = "%-" . $longest . "s";
- while ($what){
- $what =~ s/(.*\n?)//m;
- my $line = $1;
- last unless $line;
- my($nl) = chomp $line ? "\n" : "";
- # print "line[$line]ornament[$ornament]sprintf[$sprintf]\n";
- print color($ornament), sprintf($sprintf,$line), color("reset"), $nl;
- }
+ 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";
+ }
+ print $color_on,
+ $swhat,
+ Term::ANSIColor::color("reset");
} else {
- # chomp $what;
- # $what .= "\n"; # newlines unless $PRINT_ORNAMENTING
- print $what;
+ print $swhat;
}
}
+# where is myprint/mywarn/Frontend/etc. documented? We need guidelines
+# where to use what! I think, we send everything to STDOUT and use
+# print for normal/good news and warn for news that need more
+# attention. Yes, this is our working contract for now.
sub myprint {
my($self,$what) = @_;
- $self->print_ornamented($what, 'bold blue on_yellow');
+ $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
}
sub myexit {
sub mywarn {
my($self,$what) = @_;
- $self->print_ornamented($what, 'bold red on_yellow');
+ $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
}
-#sub myconfess {
-# my($self,$what) = @_;
-# $self->print_ornamented($what, 'bold red on_white');
-# Carp::confess "died";
-#}
-
# only to be used for shell commands
sub mydie {
my($self,$what) = @_;
- $self->print_ornamented($what, 'bold red on_white');
+ $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
die "\n";
}
+# sub CPAN::Shell::colorable_makemaker_prompt
+sub colorable_makemaker_prompt {
+ my($foo,$bar) = @_;
+ if (CPAN::Shell->colorize_output) {
+ my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
+ my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
+ print $color_on;
+ }
+ my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
+ if (CPAN::Shell->colorize_output) {
+ print Term::ANSIColor::color('reset');
+ }
+ return $ans;
+}
+
# use this only for unrecoverable errors!
sub unrecoverable_error {
my($self,$what) = @_;
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");
- sleep 2;
+ "not supported.\nRejecting argument '$s'\n");
+ $CPAN::Frontend->mysleep(2);
next;
} elsif ($meth eq "ls") {
$self->globls($s,\@pragma);
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));
if ($meth =~ /^(dump|ls)$/) {
$obj->$meth();
} else {
- $CPAN::Frontend->myprint(
- join "",
- "Don't be silly, you can't $meth ",
- $obj->fullname,
- " ;-)\n"
- );
- sleep 2;
+ $CPAN::Frontend->mywarn(
+ join "",
+ "Don't be silly, you can't $meth ",
+ $obj->fullname,
+ " ;-)\n"
+ );
+ $CPAN::Frontend->mysleep(2);
}
- } else {
+ } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
+ CPAN::InfoObj->dump($s);
+ } else {
$CPAN::Frontend
- ->myprint(qq{Warning: Cannot $meth $s, }.
- qq{don\'t know what it is.
+ ->mywarn(qq{Warning: Cannot $meth $s, }.
+ qq{don't know what it is.
Try the command
i /$s/
to find objects with matching identifiers.
});
- sleep 2;
+ $CPAN::Frontend->mysleep(2);
}
}
# 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
&&
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 {
@ISA = qw(Exporter LWP::UserAgent);
$SETUPDONE++;
} else {
- $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
+ $CPAN::Frontend->mywarn(" LWP::UserAgent not available\n");
}
}
o conf username your_username
o conf password your_password
)\nUsername:";
-
+
($user, $password) =
_get_username_and_password_from_user($username_prompt);
return ($user,$password);
} 0..$last;
}
my(@levels);
+ $Themethod ||= "";
+ $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
if ($Themethod) {
@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
} else {
@reordered : 0..$last; # reordered has CDROM up front
my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
for my $u (@urllist) {
- $u .= "/" unless substr($u,-1) eq "/";
+ if ($u->can("text")) {
+ $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
+ } else {
+ $u .= "/" unless substr($u,-1) eq "/";
+ $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
+ }
}
for my $u (@CPAN::Defaultsites) {
push @urllist, $u unless grep { $_ eq $u } @urllist;
}
unless ($CPAN::Signal) {
my(@mess);
- push @mess,
- qq{Please check, if the URLs I found in your configuration file \(}.
- join(", ", @{$CPAN::Config->{urllist}}).
- qq{\) are valid. The urllist can be edited.},
- qq{E.g. with 'o conf urllist push ftp://myurl/'};
- $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
- sleep 2;
- $CPAN::Frontend->myprint("Could not fetch $file\n");
+ local $" = " ";
+ if (@{$CPAN::Config->{urllist}}) {
+ push @mess,
+ qq{Please check, if the URLs I found in your configuration file \(}.
+ join(", ", @{$CPAN::Config->{urllist}}).
+ qq{\) are valid.};
+ } else {
+ push @mess, qq{Your urllist is empty!};
+ }
+ push @mess, qq{The urllist can be edited.},
+ qq{E.g. with 'o conf urllist push ftp://myurl/'};
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
+ $CPAN::Frontend->mywarn("Could not fetch $file\n");
+ $CPAN::Frontend->mysleep(2);
}
if ($restore) {
rename "$aslocal.bak", $aslocal;
}
}
if ($CPAN::META->has_usable('LWP')) {
- $CPAN::Frontend->myprint("Fetching with LWP:
+ $CPAN::Frontend->myprint("Fetching with LWP:
$url
");
- unless ($Ua) {
- CPAN::LWP::UserAgent->config;
- eval { $Ua = CPAN::LWP::UserAgent->new; };
- if ($@) {
- $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
- }
- }
- my $res = $Ua->mirror($url, $aslocal);
- if ($res->is_success) {
- $ThesiteURL = $ro_url;
- my $now = time;
- utime $now, $now, $aslocal; # download time is more
- # important than upload time
- return $aslocal;
- } elsif ($url !~ /\.gz(?!\n)\Z/) {
- my $gzurl = "$url.gz";
- $CPAN::Frontend->myprint("Fetching with LWP:
+ unless ($Ua) {
+ CPAN::LWP::UserAgent->config;
+ eval { $Ua = CPAN::LWP::UserAgent->new; };
+ if ($@) {
+ $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
+ }
+ }
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ $ThesiteURL = $ro_url;
+ my $now = time;
+ utime $now, $now, $aslocal; # download time is more
+ # important than upload
+ # time
+ return $aslocal;
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint("Fetching with LWP:
$gzurl
");
- $res = $Ua->mirror($gzurl, "$aslocal.gz");
- if ($res->is_success &&
- CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
- ) {
- $ThesiteURL = $ro_url;
- return $aslocal;
- }
- } else {
- $CPAN::Frontend->myprint(sprintf(
- "LWP failed with code[%s] message[%s]\n",
- $res->code,
- $res->message,
- ));
- # Alan Burlison informed me that in firewall environments
- # Net::FTP can still succeed where LWP fails. So we do not
- # skip Net::FTP anymore when LWP is available.
- }
- } else {
- $CPAN::Frontend->myprint("LWP not available\n");
+ $res = $Ua->mirror($gzurl, "$aslocal.gz");
+ if ($res->is_success &&
+ CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
+ ) {
+ $ThesiteURL = $ro_url;
+ return $aslocal;
+ }
+ } else {
+ $CPAN::Frontend->myprint(sprintf(
+ "LWP failed with code[%s] message[%s]\n",
+ $res->code,
+ $res->message,
+ ));
+ # Alan Burlison informed me that in firewall environments
+ # Net::FTP can still succeed where LWP fails. So we do not
+ # skip Net::FTP anymore when LWP is available.
+ }
+ } elsif (
+ $ro_url->can("text")
+ and
+ $ro_url->{FROM} eq "USER"
+ ){
+ my $ret = $self->hosthard([$ro_url],$file,$aslocal);
+ return $ret if $ret;
+ } else {
+ $CPAN::Frontend->mywarn(" LWP not available\n");
}
return if $CPAN::Signal;
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
if (-s $asl_ungz) {
my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
if ($content =~ /^<.*<title>[45]/si) {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
No success, the file that lynx has has downloaded looks like an error message:
$content
});
$CPAN::Frontend->myprint("No external ftp command available\n\n");
return;
}
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
As a last ressort we now switch to the external ftp command '$ftpbin'
to get '$aslocal'.
-Doing so often leads to problems that are hard to diagnose, even endless
-loops may be encountered.
+Doing so often leads to problems that are hard to diagnose.
If you're victim of such problems, please consider unsetting the ftp
config variable with
o conf commit
});
- $CPAN::Frontend->mysleep(4);
+ $CPAN::Frontend->mysleep(2);
HOSTHARDEST: for $ro_url (@$host_seq) {
my $url = "$ro_url$file";
$self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
$CPAN::Frontend->myprint("Bad luck... Still failed!\n");
}
return if $CPAN::Signal;
- $CPAN::Frontend->myprint("Can't access URL $url.\n\n");
- sleep 2;
+ $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
+ $CPAN::Frontend->mysleep(2);
} # host
}
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);
local($/) = "\n";
local($_);
push @lines, split /\012/ while <FH>;
+ my $i = 0;
+ my $modulus = int(@lines/75) || 1;
foreach (@lines) {
my($userid,$fullname,$email) =
m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
# 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 {
#-> 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) {
$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) {
- warn qq{Warning: Your $index_target does not contain a Line-Count header.
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
-};
+});
- sleep 5;
+ $CPAN::Frontend->mysleep(5);
} elsif ($line_count != scalar @lines) {
- warn sprintf qq{Warning: Your %s
+ $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
-$index_target, $line_count, scalar(@lines);
+$index_target, $line_count, scalar(@lines));
}
if (not defined $last_updated) {
- warn qq{Warning: Your $index_target does not contain a Last-Updated header.
+ $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
-};
+});
- sleep 5;
+ $CPAN::Frontend->mysleep(5);
} else {
$CPAN::Frontend
require HTTP::Date;
$age -= HTTP::Date::str2time($last_updated);
} else {
- $CPAN::Frontend->myprint(" HTTP::Date not available\n");
+ $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
require Time::Local;
my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
$d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
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
) {
local($^W)= 0;
if ($version > $CPAN::VERSION){
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
New CPAN.pm version (v$version) available.
[Currently running version is v$CPAN::VERSION]
You might want to try
the current session.
}); #});
- sleep 2;
+ $CPAN::Frontend->mysleep(2);
$CPAN::Frontend->myprint(qq{\n});
}
last if $CPAN::Signal;
}
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;
}
}
}
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 ;
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;
}
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;
}
#-> 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;
- print 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;
}
}
+#-> sub CPAN::Distribution::pretty_id
sub pretty_id {
my $self = shift;
my $id = $self->id;
# 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");
my $c;
foreach $c ($self->containsmods) {
my $obj = CPAN::Shell->expandany($c);
- return 0 unless $obj->uptodate;
+ unless ($obj->uptodate){
+ my $id = $self->pretty_id;
+ $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
+ return 0;
+ }
}
return 1;
}
$self->debug("Module::Signature has verified") if $CPAN::DEBUG;
}
} else {
- $CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
+ $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
}
} else {
$self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
# NFS has been reported to have racing problems after the
# renaming of a directory in some environments.
# This trick helps.
- sleep 1;
+ $CPAN::Frontend->mysleep(1);
my $mpldh = DirHandle->new($packagedir)
or Carp::croak("Couldn't opendir $packagedir: $!");
$mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
# do we have anything to do?
$self->{'configure'} = $configure;
} elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
- $CPAN::Frontend->myprint(qq{
+ $CPAN::Frontend->mywarn(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
$self->{writemakefile} = CPAN::Distrostatus->new("YES");
- sleep 2;
+ $CPAN::Frontend->mysleep(2);
} else {
my $cf = $self->called_for || "unknown";
if ($cf =~ m|/|) {
}
$cf =~ s|[/\\:]||g; # risk of filesystem damage
$cf = "unknown" unless length($cf);
- $CPAN::Frontend->myprint(qq{Package seems to come without Makefile.PL.
+ $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
(The test -f "$mpl" returned false.)
Writing one on our own (setting NAME to $cf)\a\n});
$self->{had_no_makefile_pl}++;
- sleep 3;
+ $CPAN::Frontend->mysleep(3);
# Writing our own Makefile.PL
}
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");
$local_file
with pager "$pager"
});
- sleep 2;
$fh_pager->print(<$fh_readme>);
$fh_pager->close;
}
When trying to read that file I expected to get a hash reference
for further processing, but got garbage instead.
});
- my $answer = ExtUtils::MakeMaker::prompt("Proceed nonetheless?", "no");
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
$self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
return;
has not yet been calculated, but it may also be that something is
going awry right now.
});
- my $answer = ExtUtils::MakeMaker::prompt("Proceed?", "yes");
+ my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
$answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
}
$self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
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};
}
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 (
! $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");
- sleep 2;
+ $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};
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;
- $CPAN::Frontend->myprint($@);
- $self->{writemakefile} = CPAN::Distrostatus->new("NO $@");
- $@ = "";
- return;
- }
+ }
+ } 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;
+ }
} else {
$ret = system($system);
if ($ret != 0) {
$self->{writemakefile} = CPAN::Distrostatus
->new("NO '$system' returned status $ret");
+ $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
return;
}
}
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
+ }
}
- # XXX modulebuild / make
if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = Cwd::cwd;
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
+ " in cwd[$cwd]. Danger, Will Robinson!");
+ $CPAN::Frontend->mysleep(5);
+ }
$system = sprintf "%s %s", $self->_build_command(), $CPAN::Config->{mbuild_arg};
} else {
$system = join " ", $self->_make_command(), $CPAN::Config->{make_arg};
} else {
$self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
$self->{make} = CPAN::Distrostatus->new("NO");
- $CPAN::Frontend->myprint(" $system -- NOT OK\n");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
}
#-> 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;
} elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
- my $answer = ExtUtils::MakeMaker::prompt(
+ my $answer = CPAN::Shell::colorable_makemaker_prompt(
"Shall I follow them and prepend them to the queue
of modules we are processing right now?", "yes");
$follow = $answer =~ /^\s*y/i;
# 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;
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 {
$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;
}
$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};
}
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\._]+)/) {
$CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
"requires hash: $k => $v; I'll take both ".
"key and value as a module name\n");
- sleep 1;
+ $CPAN::Frontend->mysleep(1);
$areq->{$k} = 0;
$areq->{$v} = 0;
$do_replace++;
}
$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;
}
} 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 ;
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;
$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";
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
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} || "");
} else {
$system = join " ", $self->_make_command(), "test";
}
- if (system($system) == 0) {
- $CPAN::Frontend->myprint(" $system -- OK\n");
- $CPAN::META->is_tested($self->{'build_dir'});
- $self->{make_test} = CPAN::Distrostatus->new("YES");
+ my $tests_ok;
+ if ( $CPAN::Config->{test_report} &&
+ $CPAN::META->has_inst("CPAN::Reporter") ) {
+ $tests_ok = CPAN::Reporter::test($self, $system);
+ } else {
+ $tests_ok = system($system) == 0;
+ }
+ if ( $tests_ok ) {
+ {
+ 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->myprint(" $system -- NOT OK\n");
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
+ $self->{badtestcnt}++;
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
}
}
my $system;
if ($self->{modulebuild}) {
+ unless (-f "Build") {
+ my $cwd = Cwd::cwd;
+ $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
+ " in cwd[$cwd]. Danger, Will Robinson!");
+ $CPAN::Frontend->mysleep(5);
+ }
$system = sprintf "%s clean", $self->_build_command();
} else {
$system = join " ", $self->_make_command(), "clean";
# Hmmm, what to do if make clean failed?
$self->{make_clean} = CPAN::Distrostatus->new("NO");
- $CPAN::Frontend->myprint(qq{ $system -- NOT OK\n});
+ $CPAN::Frontend->mywarn(qq{ $system -- NOT OK\n});
# 2006-02-27: seems silly to me to force a make now
# $self->force("make"); # so that this directory won't be used again
$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";
$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
(
}
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>){
- $CPAN::Frontend->myprint($_);
+ print $_; # intentionally NOT use Frontend->myprint because it
+ # looks irritating when we markup in color what we
+ # just pass through from an external program
$makeout .= $_;
}
$pipe->close;
return $self->{install} = CPAN::Distrostatus->new("YES");
} else {
$self->{install} = CPAN::Distrostatus->new("NO");
- $CPAN::Frontend->myprint(" $system -- NOT OK\n");
+ $CPAN::Frontend->mywarn(" $system -- NOT OK\n");
if (
$makeout =~ /permission/s
&& $> > 0
$url
with browser $browser
});
- sleep 2;
+ $CPAN::Frontend->mysleep(1);
system("$browser $url");
if ($saved_file) { 1 while unlink($saved_file) }
} else {
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
with pager "$pager"
});
- sleep 2;
+ $CPAN::Frontend->mysleep(1);
$fh_pager->print(<FH>);
$fh_pager->close;
} else {
return;
}
} else {
- $CPAN::Frontend->myprint("LWP not available\n");
+ $CPAN::Frontend->mywarn(" LWP not available\n");
return;
}
}
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";
}
The Bundle }.$self->id.qq{ contains
explicitly a file $s.
});
- sleep 3;
+ $CPAN::Frontend->mysleep(3);
}
# 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')
&&
#-> 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;
$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();
};
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my($self) = @_;
+ local($_); # protect against a bug in MakeMaker 6.17
my($latest) = $self->cpan_version;
$latest ||= 0;
my($inst_file) = $self->inst_file;
\n\n\n ***WARNING***
The module $self->{ID} has no active maintainer.\n\n\n
});
- sleep 5;
+ $CPAN::Frontend->mysleep(5);
}
$self->rematein('install') if $doit;
}
my($dir,@packpath);
@packpath = split /::/, $self->{ID};
$packpath[-1] .= ".pm";
+ if (@packpath == 1 && $packpath[0] eq "readline.pm") {
+ unshift @packpath, "Term", "ReadLine"; # historical reasons
+ }
foreach $dir (@INC) {
my $pmfile = File::Spec->catfile($dir,@packpath);
if (-f $pmfile){
install $distro; # same thing
CPAN::Shell->install($distro); # same thing
CPAN::Shell->expandany($distro)->install; # same thing
- CPAN::Shell->expand("Module",$distro)->install; # same thing
+ CPAN::Shell->expand("Distribution",$distro)->install; # same thing
=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
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
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<upgrade> command first runs an C<r> command and then installs
-the newest versions of all modules that were listed by that.
+The C<upgrade> command first runs an C<r> command with the given
+arguments and then installs the newest versions of all modules that
+were listed by that.
=head2 mkmyconfig
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 (C<CPAN::Shell-E<gt>install(...)>) and as
cancellation can be avoided by letting C<force> run the C<install> for
you.
+Note that install() gives no meaningful return value. See uptodate().
+
=item CPAN::Distribution::isa_perl()
Returns 1 if this distribution file seems to be a perl distribution.
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
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
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
-For data debugging there is the C<dump> command which takes the same
-arguments as make/test/install and outputs the object's Data::Dumper
-dump.
+=over 2
+
+=item o debug package...
+
+sets debug mode for packages.
+
+=item o debug -package...
+
+unsets debug mode for packages.
+
+=item o debug all
+
+turns debugging on for all packages.
+
+=item o debug number
+
+=back
+
+which sets the debugging packages directly. Note that C<o debug 0>
+turns debugging off.
+
+What seems quite a successful strategy is the combination of C<reload
+cpan> and the debugging switches. Add a new debug statement while
+running in the shell and then issue a C<reload cpan> and see the new
+debugging messages immediately without losing the current context.
+
+C<o debug> without an argument lists the valid package names and the
+current set of packages in debugging mode. C<o debug> has built-in
+completion support.
+
+For debugging of CPAN data there is the C<dump> 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
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
require() statements.
The configuration dialog can be started any time later again by
-issuing the command C< o conf init > in the CPAN shell.
+issuing the command C< o conf init > in the CPAN shell. A subset of
+the configuration dialog can be run by issuing C<o conf init WORD>
+where WORD is any valid config variable or a regular expression.
Currently the following keys in the hash reference $CPAN::Config are
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.
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
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
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<o conf> command:
=back
-=head2 Not 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
How to get a package, unwrap it, and make a change before building it?
- look Sybase::Sybperl
+Have a look at the C<look> (!) command.
=item 7)
How do I install a "DEVELOPER RELEASE" of a module?
-By default, CPAN will install the latest non-developer release of a module.
-If you want to install a dev release, you have to specify a partial path to
-the tarball you wish to install, like so:
+By default, CPAN will install the latest non-developer release of a
+module. If you want to install a dev release, you have to specify the
+partial path starting with the author id to the tarball you wish to
+install, like so:
cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
+Note that you can use the C<ls> command to get this path listed.
+
=item 13)
How do I install a module and all its dependencies from the commandline,
Andreas Koenig C<< <andk@cpan.org> >>
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
=head1 TRANSLATIONS
Kawai,Takanori provides a Japanese translation of this manpage at
projects / p5sagit/p5-mst-13.2.git / blobdiff