# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN;
-$CPAN::VERSION = '1.8801';
+$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 ();
$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--;
}
}
# 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" :
$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")) {
}
}
}
+ 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::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;
$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;
- $CPAN::Frontend->myprint("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';
}
$self->{is_tested}{$what} = 1;
}
-# looks suspicious but maybe it is really intended to set is_tested
-# here. Please document next time around
+# 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(
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;
# 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;
$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;
"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) = @_;
+ 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;
}
#-> 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;
}
=~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
}
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 $colorstyle = 0; # (=0) works, (=1) tries to make
- # background colors more attractive by
- # appending whitespace to short lines, it
- # seems also to work but is less tested;
- # for testing use the make target
- # testshell-with-protocol-twice; overall
- # seems not worth any effort
- if ($colorstyle == 1) {
- 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?
- my $nl = chomp $swhat ? "\n" : "";
- my $block = join "",
- map {
- sprintf("%s%-*s%s%s",
- $color_on,
- $longest,
- $_,
- Term::ANSIColor::color("reset"),
- $nl,
- )
- }
- split /[\r\t ]*\n/, $swhat, -1;
- print $block;
- } else {
- print $color_on,
- $swhat,
- Term::ANSIColor::color("reset");
- }
+ print $color_on,
+ $swhat,
+ Term::ANSIColor::color("reset");
} else {
print $swhat;
}
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") {
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));
);
$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/
# 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 {
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) {
$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
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
}
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;
- $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;
}
}
+#-> 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 $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");
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");
$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};
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") {
#-> 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;
# 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\._]+)/) {
}
$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} || "");
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");
}
}
$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>){
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
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";
}
# 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();
};
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
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.
+
+=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 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.
+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
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
projects / p5sagit/p5-mst-13.2.git / blobdiff