# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
-$VERSION = '1.80_56';
+$VERSION = '1.83_55';
$VERSION = eval $VERSION;
use strict;
use Carp ();
use Config ();
use Cwd ();
-use DirHandle;
+use DirHandle ();
use Exporter ();
use ExtUtils::MakeMaker (); # $SelfLoader::DEBUG=1;
use File::Basename ();
use File::Copy ();
use File::Find;
use File::Path ();
-use File::Spec;
+use File::Spec ();
use File::Temp ();
use FileHandle ();
use Safe ();
-use Sys::Hostname;
+use Sys::Hostname qw(hostname);
use Text::ParseWords ();
-use Text::Wrap;
+use Text::Wrap ();
no lib "."; # we need to run chdir all over and we would get at wrong
# libraries there
$CPAN::Signal ||= 0;
$CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "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";
perldoc recent
);
+sub soft_chdir_with_alternatives ($);
+
#-> sub CPAN::AUTOLOAD ;
sub AUTOLOAD {
my($l) = $AUTOLOAD;
}
}
-
#-> sub CPAN::shell ;
sub shell {
my($self) = @_;
$Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- my $oprompt = shift || "cpan> ";
+ my $oprompt = shift || CPAN::Prompt->new;
my $prompt = $oprompt;
my $commandline = shift || "";
+ $CPAN::CurrentCommandId ||= 1;
local($^W) = 1;
unless ($Suppress_readline) {
# no strict; # I do not recall why no strict was here (2000-09-03)
$META->checklock();
- my $cwd = CPAN::anycwd();
+ my @cwd = (CPAN::anycwd(),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" :
my $command = shift @line;
eval { CPAN::Shell->$command(@line) };
warn $@ if $@;
- chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ if ($command =~ /^(make|test|install|force|notest)$/) {
+ CPAN::Shell->failed($CPAN::CurrentCommandId,1);
+ }
+ soft_chdir_with_alternatives(\@cwd);
$CPAN::Frontend->myprint("\n");
$continuation = "";
+ $CPAN::CurrentCommandId++;
$prompt = $oprompt;
}
} continue {
}
}
}
- chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ 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.
+});
+ shift @$cwd;
+ } else {
+ $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
+ }
+ }
+}
package CPAN::CacheMgr;
use strict;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
@CPAN::Complete::COMMANDS = sort qw(
- ! a b d h i m o q r u autobundle clean dump
- make test install force readme reload look
- cvs_import ls perldoc recent
-) unless @CPAN::Complete::COMMANDS;
+ ! a b d h i m o q r u
+ autobundle
+ clean
+ cvs_import
+ dump
+ force
+ install
+ look
+ ls
+ make test
+ notest
+ perldoc
+ readme
+ recent
+ reload
+);
package CPAN::Index;
use strict;
".\nCannot continue.\n";
}
+package CPAN::Prompt; use overload '""' => "as_string";
+our $prompt = "cpan> ";
+$CPAN::CurrentCommandId ||= 0;
+sub as_randomly_capitalized_string {
+ # pure fun variant
+ substr($prompt,$_,1)=rand()<0.5 ?
+ uc(substr($prompt,$_,1)) :
+ lc(substr($prompt,$_,1)) for 0..3;
+ $prompt;
+}
+sub new {
+ bless {}, shift;
+}
+sub as_string {
+ if ($CPAN::Config->{commandnumber_in_prompt}) {
+ sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
+ } else {
+ "cpan> ";
+ }
+}
+
+package CPAN::Distrostatus;
+use overload '""' => "as_string",
+ fallback => 1;
+sub new {
+ my($class,$arg) = @_;
+ bless {
+ TEXT => $arg,
+ FAILED => substr($arg,0,2) eq "NO",
+ COMMANDID => $CPAN::CurrentCommandId,
+ }, $class;
+}
+sub commandid { shift->{COMMANDID} }
+sub failed { shift->{FAILED} }
+sub text {
+ my($self,$set) = @_;
+ if (defined $set) {
+ $self->{TEXT} = $set;
+ }
+ $self->{TEXT};
+}
+sub as_string {
+ my($self) = @_;
+ if (0) { # called from rematein during install?
+ require Carp;
+ Carp::cluck("HERE");
+ }
+ $self->{TEXT};
+}
+
package CPAN::Shell;
use strict;
use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
if (-f $lockfile && -M _ > 0) {
my $fh = FileHandle->new($lockfile) or
- $CPAN::Frontend->mydie("Could not open $lockfile: $!");
+ $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
my $otherpid = <$fh>;
my $otherhost = <$fh>;
$fh->close;
if (defined $otherhost && defined $thishost &&
$otherhost ne '' && $thishost ne '' &&
$otherhost ne $thishost) {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
"reports other host $otherhost and other process $otherpid.\n".
"Cannot proceed.\n"));
}
my($ans) =
ExtUtils::MakeMaker::prompt
(qq{Other job not responding. Shall I overwrite }.
- qq{the lockfile? (Y/N)},"y");
+ qq{the lockfile '$lockfile'? (Y/n)},"y");
$CPAN::Frontend->myexit("Ok, bye\n")
unless $ans =~ /^y/i;
} else {
Carp::croak(
- qq{Lockfile $lockfile not writeable by you. }.
+ qq{Lockfile '$lockfile' not writeable by you. }.
qq{Cannot proceed.\n}.
qq{ On UNIX try:\n}.
- qq{ rm $lockfile\n}.
+ qq{ rm '$lockfile'\n}.
qq{ and then rerun us.\n}
);
}
} else {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+ $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
"reports other process with ID ".
"$otherpid. Cannot proceed.\n"));
}
#-> sub CPAN::find_perl ;
sub find_perl {
my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
- my $pwd = CPAN::anycwd();
+ my $pwd = $CPAN::iCwd = CPAN::anycwd();
my $candidate = File::Spec->catfile($pwd,$^X);
$perl ||= $candidate if MM->maybe_command($candidate);
return if exists $self->{SIZE}{$dir};
return if $CPAN::Signal;
my($Du) = 0;
+ unless (-x $dir) {
+ unless (chmod 0755, $dir) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
+ "to change the permission; cannot estimate disk usage ".
+ "of '$dir'\n");
+ sleep 5;
+ return;
+ }
+ }
find(
- sub {
- $File::Find::prune++ if $CPAN::Signal;
- return if -l $_;
- if ($^O eq 'MacOS') {
- require Mac::Files;
- my $cat = Mac::Files::FSpGetCatInfo($_);
- $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
- } else {
- $Du += (-s _);
- }
- },
- $dir
- );
+ sub {
+ $File::Find::prune++ if $CPAN::Signal;
+ return if -l $_;
+ if ($^O eq 'MacOS') {
+ require Mac::Files;
+ my $cat = Mac::Files::FSpGetCatInfo($_);
+ $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
+ } else {
+ if (-d _) {
+ unless (-x _) {
+ unless (chmod 0755, $_) {
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
+ "the permission to change the permission; ".
+ "can only partially estimate disk usage ".
+ "of '$_'\n");
+ sleep 5;
+ return;
+ }
+ }
+ } else {
+ $Du += (-s _);
+ }
+ }
+ },
+ $dir
+ );
return if $CPAN::Signal;
$self->{SIZE}{$dir} = $Du/1024/1024;
push @{$self->{FIFO}}, $dir;
if (defined $about) {
$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
} else {
- $CPAN::Frontend->myprint(q{
-Display Information
+ my $filler = " " x (80 - 28 - length($CPAN::VERSION));
+ $CPAN::Frontend->myprint(qq{
+Display Information $filler (ver $CPAN::VERSION)
command argument description
a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules
i WORD or /REGEXP/ about any of the above
r NONE report updatable modules
- ls AUTHOR about files in the author's directory
+ ls AUTHOR or GLOB about files in the author's directory
(with WORD being a module, bundle or author name or a distribution
name of the form AUTHOR/DISTRIBUTION)
$CPAN::Frontend->myprint($self->format_result('Author',@arg));
}
-#-> sub CPAN::Shell::ls ;
-sub ls {
- my($self,@arg) = @_;
+sub handle_ls {
+ my($self,$pragmas,$s) = @_;
+ # ls is really very different, but we had it once as an ordinary
+ # command in the Shell (upto rev. 321) and we could not handle
+ # force well then
my(@accept,@preexpand);
- for my $arg (@arg) {
- if ($arg =~ /[\*\?\/]/) {
- if ($CPAN::META->has_inst("Text::Glob")) {
- if (my($au,$pathglob) = $arg =~ m|(.*?)/(.*)|) {
- my $rau = Text::Glob::glob_to_regex(uc $au);
- $self->debug("au[$au]pathglob[$pathglob]rau[$rau]") if $CPAN::DEBUG;
- push @preexpand, map { $_->id . "/" . $pathglob }
- $self->expand_by_method('CPAN::Author',['id'],"/$rau/");
- } else {
- my $rau = Text::Glob::glob_to_regex(uc $arg);
- push @preexpand, map { $_->id } $self->expand_by_method('CPAN::Author',
- ['id'],
- "/$rau/");
- }
+ if ($s =~ /[\*\?\/]/) {
+ if ($CPAN::META->has_inst("Text::Glob")) {
+ if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
+ my $rau = Text::Glob::glob_to_regex(uc $au);
+ CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
+ if $CPAN::DEBUG;
+ push @preexpand, map { $_->id . "/" . $pathglob }
+ CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
} else {
- $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
+ my $rau = Text::Glob::glob_to_regex(uc $s);
+ push @preexpand, map { $_->id }
+ CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ "/$rau/");
}
} else {
- push @preexpand, uc $arg;
+ $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
}
+ } else {
+ push @preexpand, uc $s;
}
for (@preexpand) {
unless (/^[A-Z0-9\-]+(\/|$)/i) {
if ($a =~ m|(.*?)/(.*)|) {
my $a2 = $1;
$pathglob = $2;
- $author = $self->expand_by_method('CPAN::Author',
- ['id'],
- $a2) or die "No author found for $a2";
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a2) or die "No author found for $a2";
} else {
- $author = $self->expand_by_method('CPAN::Author',
- ['id'],
- $a) or die "No author found for $a";
+ $author = CPAN::Shell->expand_by_method('CPAN::Author',
+ ['id'],
+ $a) or die "No author found for $a";
}
if ($silent) {
my $alpha = substr $author->id, 0, 1;
}
$CPAN::Frontend->myprint($ad);
}
+ for my $pragma (@$pragmas) {
+ if ($author->can($pragma)) {
+ $author->$pragma();
+ }
+ }
$author->ls($pathglob,$silent); # silent if more than one author
+ for my $pragma (@$pragmas) {
+ my $meth = "un$pragma";
+ if ($author->can($meth)) {
+ $author->$meth();
+ }
+ }
}
}
# should have been called set and 'o debug' maybe 'set debug'
sub o {
my($self,$o_type,@o_what) = @_;
+ $DB::single = 1;
$o_type ||= "";
CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
if ($o_type eq 'conf') {
}
$CPAN::Frontend->myprint("\n");
} elsif (!CPAN::HandleConfig->edit(@o_what)) {
- $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
- qq{edit options\n\n});
+ $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
+ qq{items\n\n});
}
} elsif ($o_type eq 'debug') {
my(%valid);
$self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
if ($command =~ /cpan/i) {
my $redef = 0;
- for my $f (qw(CPAN.pm CPAN/HandleConfig.pm CPAN/FirstTime.pm CPAN/Tarzip.pm
+ 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)) {
next unless $INC{$f};
my $pwd = CPAN::anycwd();
CPAN->debug("reloading the whole '$f' from '$INC{$f}' while pwd='$pwd'")
if $CPAN::DEBUG;
- my $fh = FileHandle->new($INC{$f});
+ my $read;
+ for my $inc (@INC) {
+ $read = File::Spec->catfile($inc,split /\//, $f);
+ last if -f $read;
+ }
+ unless (-f $read) {
+ $failed++;
+ $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
+ next MFILE;
+ }
+ my $fh = FileHandle->new($read) or
+ $CPAN::Frontend->mydie("Could not open $read: $!");
local($/);
local $^W = 1;
local($SIG{__WARN__}) = paintdots_onreload(\$redef);
my $eval = <$fh>;
- CPAN->debug("evaling '$eval'")
+ CPAN->debug(sprintf("evaling [%s...]\n",substr($eval,0,64)))
if $CPAN::DEBUG;
eval $eval;
- warn $@ if $@;
+ if ($@){
+ $failed++;
+ warn $@;
+ }
}
$CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
+ $failed++ unless $redef;
+ if ($failed) {
+ $CPAN::Frontend->mywarn("\n$failed errors during reload. You better quit ".
+ "this session.\n");
+ }
} elsif ($command =~ /index/) {
CPAN::Index->force_reload;
} else {
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
- $module->{RO}{description}
+ $module->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
shift->_u_r_common("u",@_);
}
+# XXX intentionally undocumented because not considered enough
+#-> sub CPAN::Shell::failed ;
+sub failed {
+ my($self,$only_id,$silent) = @_;
+ my $print = "";
+ DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
+ my $failed = "";
+ for my $nosayer (qw(signature_verify make make_test install)) {
+ next unless exists $d->{$nosayer};
+ next unless $d->{$nosayer}->failed;
+ $failed = $nosayer;
+ last;
+ }
+ next DIST unless $failed;
+ next DIST if $only_id && $only_id != $d->{$failed}->commandid;
+ my $id = $d->id;
+ $id =~ s|^./../||;
+ $print .= sprintf(
+ " %-45s: %s %s\n",
+ $id,
+ $failed,
+ $d->{$failed}->text,
+ );
+ }
+ my $scope = $only_id ? "command" : "session";
+ if ($print) {
+ $CPAN::Frontend->myprint("Failed installations in this $scope:\n$print");
+ } elsif (!$only_id || !$silent) {
+ $CPAN::Frontend->myprint("No installations failed in this $scope\n");
+ }
+}
+
+# XXX intentionally undocumented because not considered enough
+#-> sub CPAN::Shell::status ;
+sub status {
+ my($self) = @_;
+ require Devel::Size;
+ my $ps = FileHandle->new;
+ open $ps, "/proc/$$/status";
+ my $vm = 0;
+ while (<$ps>) {
+ next unless /VmSize:\s+(\d+)/;
+ $vm = $1;
+ last;
+ }
+ $CPAN::Frontend->mywarn(sprintf(
+ "%-27s %6d\n%-27s %6d\n",
+ "vm",
+ $vm,
+ "CPAN::META",
+ Devel::Size::total_size($CPAN::META)/1024,
+ ));
+ for my $k (sort keys %$CPAN::META) {
+ 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",
+ $k2,
+ Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
+ scalar keys %{$CPAN::META->{$k}{$k2}};
+ }
+ }
+}
+
#-> sub CPAN::Shell::autobundle ;
sub autobundle {
my($self) = shift;
die "\n";
}
+sub mysleep {
+ my($self, $sleep) = @_;
+ sleep $sleep;
+}
+
sub setup_output {
return if -t STDOUT;
my $odef = select STDERR;
#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall
sub rematein {
- shift;
+ my $self = shift;
my($meth,@some) = @_;
my @pragma;
while($meth =~ /^(force|notest)$/) {
push @pragma, $meth;
- $meth = shift @some;
+ $meth = shift @some or
+ $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
+ "cannot continue");
}
setup_output();
CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
# construct the queue
my($s,@s,@qcopy);
- foreach $s (@some) {
+ STHING: foreach $s (@some) {
my $obj;
if (ref $s) {
CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
"not supported\n");
sleep 2;
next;
- } else {
+ } elsif ($meth eq "ls") {
+ $self->handle_ls(\@pragma,$s);
+ next STHING;
+ } else {
CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
$obj = CPAN::Shell->expandany($s);
}
# set up the dispatching methods
no strict "refs";
for my $command (qw(
- clean cvs_import dump force get install look
- make notest perldoc readme test
+ clean
+ cvs_import
+ dump
+ force
+ get
+ install
+ look
+ ls
+ make
+ notest
+ perldoc
+ readme
+ test
)) {
*$command = sub { shift->rematein($command, @_); };
}
#-> sub CPAN::FTP::ftp_get ;
sub ftp_get {
- my($class,$host,$dir,$file,$target) = @_;
- $class->debug(
- qq[Going to fetch file [$file] from dir [$dir]
+ my($class,$host,$dir,$file,$target) = @_;
+ $class->debug(
+ qq[Going to fetch file [$file] from dir [$dir]
on host [$host] as local [$target]\n]
- ) if $CPAN::DEBUG;
- my $ftp = Net::FTP->new($host);
- return 0 unless defined $ftp;
- $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
- $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
- unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
- warn "Couldn't login on $host";
- return;
- }
- unless ( $ftp->cwd($dir) ){
- warn "Couldn't cwd $dir";
- return;
- }
- $ftp->binary;
- $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
- unless ( $ftp->get($file,$target) ){
- warn "Couldn't fetch $file from $host\n";
- return;
- }
- $ftp->quit; # it's ok if this fails
- return 1;
+ ) if $CPAN::DEBUG;
+ my $ftp = Net::FTP->new($host);
+ unless ($ftp) {
+ $CPAN::Frontend->mywarn(" Could not connect to host '$host' with Net::FTP\n");
+ return;
+ }
+ return 0 unless defined $ftp;
+ $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
+ $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
+ unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't login on $host: $msg");
+ return;
+ }
+ unless ( $ftp->cwd($dir) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't cwd $dir: $msg");
+ return;
+ }
+ $ftp->binary;
+ $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ){
+ my $msg = $ftp->message;
+ $CPAN::Frontend->mywarn(" Couldn't fetch $file from $host: $msg");
+ return;
+ }
+ $ftp->quit; # it's ok if this fails
+ return 1;
}
# If more accuracy is wanted/needed, Chris Leach sent me this patch...
}
}
- return $aslocal if -f $aslocal && -r _ && !($force & 1);
+ if (-f $aslocal && -r _ && !($force & 1)){
+ if (-s $aslocal) {
+ return $aslocal;
+ } else {
+ # empty file from a previous unsuccessful attempt to download it
+ unlink $aslocal or
+ $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I could not remove.");
+ }
+ }
my($restore) = 0;
if (-f $aslocal){
rename $aslocal, "$aslocal.bak";
} elsif ($words[1] eq 'conf') {
return CPAN::HandleConfig::cpl(@_);
} elsif ($words[1] eq 'debug') {
- return sort grep /^\Q$word\E/,
+ return sort grep /^\Q$word\E/i,
sort keys %CPAN::DEBUG, 'all';
}
}
$last_updated);
$DATE_OF_02 = $last_updated;
+ my $age = time;
if ($CPAN::META->has_inst('HTTP::Date')) {
require HTTP::Date;
- my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24;
- if ($age > 30) {
+ $age -= HTTP::Date::str2time($last_updated);
+ } else {
+ $CPAN::Frontend->myprint(" 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;
+ $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
+ }
+ $age /= 3600*24;
+ if ($age > 30) {
- $CPAN::Frontend
- ->mywarn(sprintf
- qq{Warning: This index file is %d days old.
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: This index file is %d days old.
Please check the host you chose as your CPAN mirror for staleness.
I'll continue but problems seem likely to happen.\a\n},
- $age);
+ $age);
+
+ } elsif ($age < -1) {
+
+ $CPAN::Frontend
+ ->mywarn(sprintf
+ qq{Warning: Your system date is %d days behind this index file!
+ System time: %s
+ Timestamp index file: %s
+ Please fix your system time, problems with the make command expected.\n},
+ -$age,
+ scalar gmtime,
+ $DATE_OF_02,
+ );
- }
- } else {
- $CPAN::Frontend->myprint(" HTTP::Date not available\n");
}
}
package CPAN::InfoObj;
use strict;
-# Accessors
+sub ro {
+ my $self = shift;
+ exists $self->{RO} and return $self->{RO};
+}
+
sub cpan_userid {
my $self = shift;
- $self->{RO}{CPAN_USERID}
+ my $ro = $self->ro or return;
+ return $ro->{CPAN_USERID};
}
sub id { shift->{ID}; }
my $class = ref($self);
$class =~ s/^CPAN:://;
push @m, $class, " id = $self->{ID}\n";
- for (sort keys %{$self->{RO}}) {
+ my $ro = $self->ro;
+ for (sort keys %$ro) {
# next if m/^(ID|RO)$/;
my $extra = "";
if ($_ eq "CPAN_USERID") {
push @m, sprintf " %-12s %s\n", $_, $self->fullname;
next;
}
- next unless defined $self->{RO}{$_};
- push @m, sprintf " %-12s %s%s\n", $_, $self->{RO}{$_}, $extra;
+ next unless defined $ro->{$_};
+ push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
}
for (sort keys %$self) {
next if m/^(ID|RO)$/;
package CPAN::Author;
use strict;
+#-> sub CPAN::Author::force
+sub force {
+ my $self = shift;
+ $self->{force}++;
+}
+
+#-> sub CPAN::Author::force
+sub unforce {
+ my $self = shift;
+ delete $self->{force};
+}
+
#-> sub CPAN::Author::id
sub id {
my $self = shift;
#-> sub CPAN::Author::fullname ;
sub fullname {
- shift->{RO}{FULLNAME};
+ shift->ro->{FULLNAME};
}
*name = \&fullname;
#-> sub CPAN::Author::email ;
-sub email { shift->{RO}{EMAIL}; }
+sub email { shift->ro->{EMAIL}; }
#-> sub CPAN::Author::ls ;
sub ls {
local($") = "/";
# connect "force" argument with "index_expire".
- my $force = 0;
+ my $force = $self->{force};
if (my @stat = stat $lc_want) {
- $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
+ $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
}
my $lc_file;
if ($may_ftp) {
use strict;
# Accessors
-sub cpan_comment { shift->{RO}{CPAN_COMMENT} }
+sub cpan_comment {
+ my $self = shift;
+ my $ro = $self->ro or return;
+ $ro->{CPAN_COMMENT}
+}
sub undelay {
my $self = shift;
delete $self->{later};
}
+# add the A/AN/ stuff
# CPAN::Distribution::normalize
sub normalize {
my($self,$s) = @_;
$s;
}
+sub pretty_id {
+ my $self = shift;
+ my $id = $self->id;
+ return $id unless $id =~ m|^./../|;
+ substr($id,5);
+}
+
# mark as dirty/clean
#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
#-> sub CPAN::Distribution::safe_chdir ;
sub safe_chdir {
- my($self,$todir) = @_;
- # we die if we cannot chdir and we are debuggable
- Carp::confess("safe_chdir called without todir argument")
- unless defined $todir and length $todir;
- if (chdir $todir) {
- $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
- if $CPAN::DEBUG;
- } else {
+ my($self,$todir) = @_;
+ # we die if we cannot chdir and we are debuggable
+ Carp::confess("safe_chdir called without todir argument")
+ unless defined $todir and length $todir;
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ unless (-x $todir) {
+ unless (chmod 0755, $todir) {
my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mywarn("I have neither the -x permission nor the permission ".
+ "to change the permission; cannot chdir ".
+ "to '$todir'\n");
+ sleep 5;
$CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
qq{to todir[$todir]: $!});
+ }
+ }
+ if (chdir $todir) {
+ $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
+ if $CPAN::DEBUG;
+ } else {
+ my $cwd = CPAN::anycwd();
+ $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
+ qq{to todir[$todir] (a chmod has been issued): $!});
}
+ }
}
#-> sub CPAN::Distribution::get ;
)->as_string
);
- my $wrap = qq{I\'d recommend removing $self->{localfile}. Its signature
+ my $wrap =
+ sprintf(qq{I'd recommend removing %s. Its signature
is invalid. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
-retry.};
- $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+retry. For more information, try opening a subshell with
+ look %s
+and there run
+ cpansign -v
+},
+ $self->{localfile},
+ $self->pretty_id,
+ );
+ $self->{signature_verify} = CPAN::Distrostatus->new("NO");
+ $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
+ $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
+ } else {
+ $self->{signature_verify} = CPAN::Distrostatus->new("YES");
}
} else {
$CPAN::Frontend->myprint(qq{Package came without SIGNATURE\n\n});
my $pwd = CPAN::anycwd();
$self->safe_chdir($dir);
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
- unless (system($CPAN::Config->{'shell'}) == 0) {
- my $code = $? >> 8;
- $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ {
+ local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
+ $ENV{CPAN_SHELL_LEVEL} += 1;
+ unless (system($CPAN::Config->{'shell'}) == 0) {
+ my $code = $? >> 8;
+ $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+ }
}
$self->safe_chdir($pwd);
}
)) {
delete $self->{$att};
}
- if ($method && $method eq "install") {
+ if ($method && $method =~ /make|test|install/) {
$self->{"force_update"}++; # name should probably have been force_install
}
}
}
$self->get;
EXCUSE: {
- my @e;
- $self->{archived} eq "NO" and push @e,
- "Is neither a tar nor a zip archive.";
+ my @e;
+ !$self->{archived} || $self->{archived} eq "NO" and push @e,
+ "Is neither a tar nor a zip archive.";
+
+ !$self->{unwrapped} || $self->{unwrapped} eq "NO" and push @e,
+ "Had problems unarchiving. Please build manually";
- $self->{unwrapped} eq "NO" and push @e,
- "had problems unarchiving. Please build manually";
+ unless ($self->{force_update}) {
+ exists $self->{signature_verify} and $self->{signature_verify}->failed
+ and push @e, "Did not pass the signature test.";
+ }
- exists $self->{writemakefile} &&
- $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
- $1 || "Had some problem writing Makefile";
+ exists $self->{writemakefile} &&
+ $self->{writemakefile} =~ m/ ^ NO\s* ( .* ) /sx and push @e,
+ $1 || "Had some problem writing Makefile";
defined $self->{'make'} and push @e,
"Has already been processed within this session";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
$CPAN::Frontend->myprint("\n CPAN.pm: Going to build ".$self->id."\n\n");
- my $builddir = $self->dir;
+ my $builddir = $self->dir or
+ $CPAN::Frontend->mydie("PANIC: Cannot determine build directory");
chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
$self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
if ($self->{modulebuild}) {
$system = "./Build $CPAN::Config->{mbuild_arg}";
} else {
- $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
+ $system = join " ", _make_command(), $CPAN::Config->{make_arg};
}
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
- $self->{'make'} = "YES";
+ $self->{'make'} = CPAN::Distrostatus->new("YES");
} else {
$self->{writemakefile} ||= "YES";
- $self->{'make'} = "NO";
+ $self->{'make'} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
}
}
+sub _make_command {
+ return $CPAN::Config->{'make'} || $Config::Config{make} || 'make';
+}
+
sub follow_prereqs {
my($self) = shift;
my(@prereq) = grep {$_ ne "perl"} @_;
}
my $areq;
my $do_replace;
- while (my($k,$v) = each %$req) {
+ while (my($k,$v) = each %{$req||{}}) {
if ($v =~ /\d/) {
$areq->{$k} = $v;
} elsif ($k =~ /[A-Za-z]/ &&
}
last;
}
+ } elsif (-f "Build") {
+ if ($CPAN::META->has_inst("Module::Build")) {
+ $req = Module::Build->current->requires();
+ }
}
}
$self->{prereq_pm_detected}++;
"Make had some problems, maybe interrupted? Won't test";
exists $self->{'make'} and
- $self->{'make'} eq 'NO' and
+ $self->{'make'}->failed and
push @e, "Can't test without successful make";
exists $self->{build_dir} or push @e, "Has no own directory";
if ($self->{modulebuild}) {
$system = "./Build test";
} else {
- $system = join " ", $CPAN::Config->{'make'}, "test";
+ $system = join " ", _make_command(), "test";
}
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_tested($self->{'build_dir'});
- $self->{make_test} = "YES";
+ $self->{make_test} = CPAN::Distrostatus->new("YES");
} else {
- $self->{make_test} = "NO";
+ $self->{make_test} = CPAN::Distrostatus->new("NO");
$self->{badtestcnt}++;
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
}
if ($self->{modulebuild}) {
$system = "./Build clean";
} else {
- $system = join " ", $CPAN::Config->{'make'}, "clean";
+ $system = join " ", _make_command(), "clean";
}
if (system($system) == 0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
"Make had some problems, maybe interrupted? Won't install";
exists $self->{'make'} and
- $self->{'make'} eq 'NO' and
+ $self->{'make'}->failed and
push @e, "make had returned bad status, install seems impossible";
- push @e, "make test had returned bad status, ".
- "won't install without force"
- if exists $self->{'make_test'} and
- $self->{'make_test'} eq 'NO' and
- ! $self->{'force_update'};
-
+ if (exists $self->{make_test} and
+ $self->{make_test}->failed){
+ if ($self->{force_update}) {
+ $self->{make_test}->text("FAILED but failure ignored because ".
+ "'force' in effect");
+ } else {
+ push @e, "make test had returned bad status, ".
+ "won't install without force"
+ }
+ }
exists $self->{'install'} and push @e,
- $self->{'install'} eq "YES" ?
+ $self->{'install'}->text eq "YES" ?
"Already done" : "Already tried without success";
exists $self->{later} and length($self->{later}) and
);
} else {
my($make_install_make_command) = $CPAN::Config->{'make_install_make_command'} ||
- $CPAN::Config->{'make'};
+ _make_command();
$system = join(" ",
$make_install_make_command,
"install",
if ($?==0) {
$CPAN::Frontend->myprint(" $system -- OK\n");
$CPAN::META->is_installed($self->{'build_dir'});
- return $self->{'install'} = "YES";
+ return $self->{'install'} = CPAN::Distrostatus->new("YES");
} else {
- $self->{'install'} = "NO";
+ $self->{'install'} = CPAN::Distrostatus->new("NO");
$CPAN::Frontend->myprint(" $system -- NOT OK\n");
if (
$makeout =~ /permission/s
# sub CPAN::Module::userid
sub userid {
my $self = shift;
- return unless exists $self->{RO}; # should never happen
- return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
+ my $ro = $self->ro;
+ return unless $ro;
+ return $ro->{userid} || $ro->{CPAN_USERID};
}
# sub CPAN::Module::description
-sub description { shift->{RO}{description} }
+sub description {
+ my $self = shift;
+ my $ro = $self->ro or return "";
+ $ro->{description}
+}
sub undelay {
my $self = shift;
&&
$CPAN::META->has_inst("Term::ANSIColor")
&&
- $self->{RO}{description}
+ $self->description
) {
$color_on = Term::ANSIColor::color("green");
$color_off = Term::ANSIColor::color("reset");
$stats{' '} = 'unknown';
$statl{' '} = 'unknown';
$stati{' '} = 'unknown';
+ my $ro = $self->ro;
push @m, sprintf(
$sprintf3,
'DSLI_STATUS',
- $self->{RO}{statd},
- $self->{RO}{stats},
- $self->{RO}{statl},
- $self->{RO}{stati},
- $statd{$self->{RO}{statd}},
- $stats{$self->{RO}{stats}},
- $statl{$self->{RO}{statl}},
- $stati{$self->{RO}{stati}}
- ) if $self->{RO}{statd};
+ $ro->{statd},
+ $ro->{stats},
+ $ro->{statl},
+ $ro->{stati},
+ $statd{$ro->{statd}},
+ $stats{$ro->{stats}},
+ $statl{$ro->{statl}},
+ $stati{$ro->{stati}}
+ ) if $ro && $ro->{statd};
my $local_file = $self->inst_file;
unless ($self->{MANPAGE}) {
if ($local_file) {
sub cpan_file {
my $self = shift;
CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
- unless (defined $self->{RO}{CPAN_FILE}) {
+ unless ($self->ro) {
CPAN::Index->reload;
}
- if (exists $self->{RO}{CPAN_FILE} && defined $self->{RO}{CPAN_FILE}){
- return $self->{RO}{CPAN_FILE};
+ my $ro = $self->ro;
+ if ($ro && defined $ro->{CPAN_FILE}){
+ return $ro->{CPAN_FILE};
} else {
my $userid = $self->userid;
if ( $userid ) {
sub cpan_version {
my $self = shift;
- $self->{RO}{CPAN_VERSION} = 'undef'
- unless defined $self->{RO}{CPAN_VERSION};
- # I believe this is always a bug in the index and should be reported
- # as such, but usually I find out such an error and do not want to
- # provoke too many bugreports
-
- $self->{RO}{CPAN_VERSION};
+ my $ro = $self->ro;
+ unless ($ro) {
+ # Can happen with modules that are not on CPAN
+ $ro = {};
+ }
+ $ro->{CPAN_VERSION} = 'undef'
+ unless defined $ro->{CPAN_VERSION};
+ $ro->{CPAN_VERSION};
}
#-> sub CPAN::Module::force ;
&&
not exists $self->{'force_update'}
) {
- $CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+ $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
+ $self->id,
+ $self->inst_version,
+ ));
} else {
$doit = 1;
}
- if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
+ my $ro = $self->ro;
+ if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
$CPAN::Frontend->mywarn(qq{
\n\n\n ***WARNING***
The module $self->{ID} has no active maintainer.\n\n\n
The last example is very slow and outputs extra progress indicators
that break the alignment of the result.
+=item failed
+
+The C<failed> command reports all distributions that failed on one of
+C<make>, C<test> or C<install> for some reason in the currently
+running shell session.
+
=item Signals
CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
=item CPAN::Index::reload()
-Reloads all indices if they have been read more than
+Reloads all indices if they have not been read for more than
C<$CPAN::Config->{index_expire}> days.
=item CPAN::InfoObj::dump()
There's no strong security layer in CPAN.pm. CPAN.pm helps you to
install foreign, unmasked, unsigned code on your machine. We compare
to a checksum that comes from the net just as the distribution file
-itself. If somebody has managed to tamper with the distribution file,
-they may have as well tampered with the CHECKSUMS file. Future
-development will go towards strong authentication.
+itself. But we try to make it easy to add security on demand:
+
+=head2 Cryptographically signed modules
+
+Since release 1.77 CPAN.pm has been able to verify cryptographically
+signed module distributions using Module::Signature. The CPAN modules
+can be signed by their authors, thus giving more security. The simple
+unsigned MD5 checksums that were used before by CPAN protect mainly
+against accidental file corruption.
+
+You will need to have Module::Signature installed, which in turn
+requires that you have at least one of Crypt::OpenPGP module or the
+command-line F<gpg> tool installed.
+
+You will also need to be able to connect over the Internet to the public
+keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
=head1 EXPORT
for this is that the primary use is intended for the cpan shell or for
one-liners.
+=head1 ENVIRONMENT
+
+When the CPAN shell enters a subshell via the look command, it sets
+the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
+already set.
+
=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
Populating a freshly installed perl with my favorite modules is pretty
Your mileage may vary...
-=head1 Cryptographically signed modules
-
-Since release 1.77 CPAN.pm has been able to verify cryptographically
-signed module distributions using Module::Signature. The CPAN modules
-can be signed by their authors, thus giving more security. The simple
-unsigned MD5 checksums that were used before by CPAN protect mainly
-against accidental file corruption.
-
-You will need to have Module::Signature installed, which in turn
-requires that you have at least one of Crypt::OpenPGP module or the
-command-line F<gpg> tool installed.
-
-You will also need to be able to connect over the Internet to the public
-keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
-
=head1 FAQ
=over 4
This does a bit more than really needed because it untars the
distribution again and runs make and test and only then install.
+Or, if you find this is too fast and you would prefer to do smaller
+steps, say
+
+ force get Foo::Bar
+
+first and then continue as always. C<Force get> I<forgets> previous
+error conditions.
+
Or you can use
look Foo::Bar
Or you leave the CPAN shell and start it again.
-Or, if you're not really sure and just want to run some make, test or
-install command without this pesky error message, say C<force get
-Foo::Bar> first and then continue as always. C<Force get> I<forgets>
-previous error conditions.
-
For the really curious, by accessing internals directly, you I<could>
! delete CPAN::Shell->expand("Distribution", \
CPAN::Shell->expand("Module","Foo::Bar") \
- ->{RO}{CPAN_FILE})->{install}
+ ->cpan_file)->{install}
but this is neither guaranteed to work in the future nor is it a
decent command.
cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# End: