summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/CPAN.pm464
-rw-r--r--lib/CPAN/FirstTime.pm36
2 files changed, 384 insertions, 116 deletions
diff --git a/lib/CPAN.pm b/lib/CPAN.pm
index 84dfd31a2b..641ff36ff7 100644
--- a/lib/CPAN.pm
+++ b/lib/CPAN.pm
@@ -2,17 +2,17 @@ package CPAN;
use vars qw{$Try_autoload
$Revision
$META $Signal $Cwd $End
- $Suppress_readline %Dontload
+ $Suppress_readline
$Frontend $Defaultsite
}; #};
-$VERSION = '1.52';
+$VERSION = '1.56';
-# $Id: CPAN.pm,v 1.276 2000/01/08 15:29:46 k Exp $
+# $Id: CPAN.pm,v 1.303 2000/08/01 15:57:15 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.276 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.303 $, 10)."]";
use Carp ();
use Config ();
@@ -29,6 +29,8 @@ use Safe ();
use Text::ParseWords ();
use Text::Wrap;
use File::Spec;
+no lib "."; # we need to run chdir all over and we would get at wrong
+ # libraries there
END { $End++; &cleanup; }
@@ -55,7 +57,7 @@ $CPAN::Frontend ||= "CPAN::Shell";
$CPAN::Defaultsite ||= "ftp://ftp.perl.org/pub/CPAN";
package CPAN;
-use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $term);
+use vars qw($VERSION @EXPORT $AUTOLOAD $DEBUG $META $HAS_USABLE $term);
use strict qw(vars);
@CPAN::ISA = qw(CPAN::Debug Exporter);
@@ -293,7 +295,7 @@ sub try_dot_al {
$pkg =~ s|::|/|g;
if (defined($name=$INC{"$pkg.pm"}))
{
- $name =~ s|^(.*)$pkg\.pm\z|$1auto/$pkg/$func.al|s;
+ $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|s;
$name = undef unless (-r $name);
}
unless (defined $name)
@@ -309,7 +311,7 @@ sub try_dot_al {
*$autoload = sub {};
$ok = 1;
} else {
- if ($name =~ s{(\w{12,})\.al\z}{substr($1,0,11).".al"}e){
+ if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
eval {local $SIG{__DIE__};require $name};
}
if ($@){
@@ -672,16 +674,56 @@ sub delete {
delete $META->{$class}{$id};
}
+#-> sub CPAN::has_usable
+# has_inst is sometimes too optimistic, we should replace it with this
+# has_usable whenever a case is given
+sub has_usable {
+ my($self,$mod,$message) = @_;
+ return 1 if $HAS_USABLE->{$mod};
+ my $has_inst = $self->has_inst($mod,$message);
+ return unless $has_inst;
+ my $capabilities;
+ $capabilities = {
+ LWP => [ # we frequently had "Can't locate object
+ # method "new" via package
+ # "LWP::UserAgent" at (eval 69) line
+ # 2006
+ sub {require LWP},
+ sub {require LWP::UserAgent},
+ sub {require HTTP::Request},
+ sub {require URI::URL},
+ ],
+ Net::FTP => [
+ sub {require Net::FTP},
+ sub {require Net::Config},
+ ]
+ };
+ if ($capabilities->{$mod}) {
+ for my $c (0..$#{$capabilities->{$mod}}) {
+ my $code = $capabilities->{$mod}[$c];
+ my $ret = eval { &$code() };
+ if ($@) {
+ warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
+ return;
+ }
+ }
+ }
+ return $HAS_USABLE->{$mod} = 1;
+}
+
#-> sub CPAN::has_inst
sub has_inst {
my($self,$mod,$message) = @_;
Carp::croak("CPAN->has_inst() called without an argument")
unless defined $mod;
- if (defined $message && $message eq "no") {
- $Dontload{$mod}||=1;
- return 0;
- } elsif (exists $Dontload{$mod}) {
- return 0;
+ if (defined $message && $message eq "no"
+ ||
+ exists $CPAN::META->{dontload_hash}{$mod}
+ ||
+ exists $CPAN::Config->{dontload_hash}{$mod}
+ ) {
+ $CPAN::META->{dontload_hash}{$mod}||=1;
+ return 0;
}
my $file = $mod;
my $obj;
@@ -942,6 +984,7 @@ sub debug {
package CPAN::Config;
#-> sub CPAN::Config::edit ;
+# returns true on successful action
sub edit {
my($class,@args) = @_;
return unless @args;
@@ -952,22 +995,31 @@ sub edit {
$class->$o(@args);
return 1;
} else {
- if (ref($CPAN::Config->{$o}) eq ARRAY) {
+ CPAN->debug("o[$o]");
+ if ($o =~ /list$/) {
$func = shift @args;
$func ||= "";
+ CPAN->debug("func[$func]");
+ my $changed;
# Let's avoid eval, it's easier to comprehend without.
if ($func eq "push") {
push @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
} elsif ($func eq "pop") {
pop @{$CPAN::Config->{$o}};
+ $changed = 1;
} elsif ($func eq "shift") {
shift @{$CPAN::Config->{$o}};
+ $changed = 1;
} elsif ($func eq "unshift") {
unshift @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
} elsif ($func eq "splice") {
splice @{$CPAN::Config->{$o}}, @args;
+ $changed = 1;
} elsif (@args) {
$CPAN::Config->{$o} = [@args];
+ $changed = 1;
} else {
$CPAN::Frontend->myprint(
join "",
@@ -976,6 +1028,12 @@ sub edit {
"\n"
);
}
+ if ($o eq "urllist" && $changed) {
+ # reset the cached values
+ undef $CPAN::FTP::Thesite;
+ undef $CPAN::FTP::Themethod;
+ }
+ return $changed;
} else {
$CPAN::Config->{$o} = $args[0] if defined $args[0];
$CPAN::Frontend->myprint(" $o " .
@@ -1005,7 +1063,8 @@ Please specify a filename where to save the configuration or try
}
}
- my $msg = <<EOF unless $configpm =~ /MyConfig/;
+ my $msg;
+ $msg = <<EOF unless $configpm =~ /MyConfig/;
# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
@@ -1241,7 +1300,14 @@ Other
*help = \&h;
#-> sub CPAN::Shell::a ;
-sub a { $CPAN::Frontend->myprint(shift->format_result('Author',@_));}
+sub a {
+ my($self,@arg) = @_;
+ # authors are always UPPERCASE
+ for (@arg) {
+ $_ = uc $_;
+ }
+ $CPAN::Frontend->myprint($self->format_result('Author',@arg));
+}
#-> sub CPAN::Shell::b ;
sub b {
my($self,@which) = @_;
@@ -1253,7 +1319,7 @@ sub b {
my($entry);
for $entry ($dh->read) {
next if -d MM->catdir($bdir,$entry);
- next unless $entry =~ s/\.pm\z//;
+ next unless $entry =~ s/\.pm$//;
$CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
}
}
@@ -1310,6 +1376,7 @@ sub o {
for $k (sort keys %$CPAN::Config) {
$v = $CPAN::Config->{$k};
if (ref $v) {
+ my(@report) = ref $v eq "ARRAY" ? @$v : %$v;
$CPAN::Frontend->myprint(
join(
"",
@@ -1317,7 +1384,7 @@ sub o {
" %-18s\n",
$k
),
- map {"\t$_\n"} @{$v}
+ map {"\t$_\n"} @report
)
);
} else {
@@ -1424,12 +1491,21 @@ index re-reads the index files\n});
sub _binary_extensions {
my($self) = shift @_;
my(@result,$module,%seen,%need,$headerdone);
- my $isaperl = q{perl5[._-]\\d{3}(_[0-4][0-9])?\\.tar[._-]gz\z};
+ my $isaperl = q{ perl
+ -?
+ 5[._-]
+ (
+ \\d{3}(_[0-4][0-9])?
+ |
+ \\d*[24680]\\.\\d+
+ )
+ \\.tar[._-]gz$
+ };
for $module ($self->expand('Module','/./')) {
my $file = $module->cpan_file;
next if $file eq "N/A";
next if $file =~ /^Contact Author/;
- next if $file =~ / $isaperl /xo;
+ next if $file =~ / $isaperl /x;
next unless $module->xs_file;
local($|) = 1;
$CPAN::Frontend->myprint(".");
@@ -1973,8 +2049,7 @@ sub localize {
to insufficient permissions.\n}) unless -w $aslocal_dir;
# Inheritance is not easier to manage than a few if/else branches
- if ($CPAN::META->has_inst('LWP::UserAgent')) {
- require LWP::UserAgent;
+ if ($CPAN::META->has_usable('LWP::UserAgent')) {
unless ($Ua) {
$Ua = LWP::UserAgent->new;
my($var);
@@ -2065,8 +2140,7 @@ sub hosteasy {
$self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
if ($url =~ /^file:/) {
my $l;
- if ($CPAN::META->has_inst('LWP')) {
- require URI::URL;
+ if ($CPAN::META->has_inst('URI::URL')) {
my $u = URI::URL->new($url);
$l = $u->path;
} else { # works only on Unix, is poorly constructed, but
@@ -2095,7 +2169,7 @@ sub hosteasy {
}
}
}
- if ($CPAN::META->has_inst('LWP')) {
+ if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
");
@@ -2110,7 +2184,7 @@ sub hosteasy {
utime $now, $now, $aslocal; # download time is more
# important than upload time
return $aslocal;
- } elsif ($url !~ /\.gz\z/) {
+ } elsif ($url !~ /\.gz$/) {
my $gzurl = "$url.gz";
$CPAN::Frontend->myprint("Fetching with LWP:
$gzurl
@@ -2136,7 +2210,7 @@ sub hosteasy {
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
# that's the nice and easy way thanks to Graham
my($host,$dir,$getfile) = ($1,$2,$3);
- if ($CPAN::META->has_inst('Net::FTP')) {
+ if ($CPAN::META->has_usable('Net::FTP')) {
$dir =~ s|/+|/|g;
$CPAN::Frontend->myprint("Fetching with Net::FTP:
$url
@@ -2147,7 +2221,7 @@ sub hosteasy {
$Thesite = $i;
return $aslocal;
}
- if ($aslocal !~ /\.gz\z/) {
+ if ($aslocal !~ /\.gz$/) {
my $gz = "$aslocal.gz";
$CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
@@ -2207,83 +2281,79 @@ sub hosthard {
$funkyftp = $CPAN::Config->{$f};
next unless defined $funkyftp;
next if $funkyftp =~ /^\s*$/;
- my($want_compressed);
- my $aslocal_uncompressed;
- ($aslocal_uncompressed = $aslocal) =~ s/\.gz//;
- my($source_switch) = "";
+ my($asl_ungz, $asl_gz);
+ ($asl_ungz = $aslocal) =~ s/\.gz//;
+ $asl_gz = "$asl_ungz.gz";
+ my($src_switch) = "";
if ($f eq "lynx"){
- $source_switch = " -source";
+ $src_switch = " -source";
} elsif ($f eq "ncftp"){
- $source_switch = " -c";
+ $src_switch = " -c";
}
my($chdir) = "";
- my($stdout_redir) = " > $aslocal_uncompressed";
+ my($stdout_redir) = " > $asl_ungz";
if ($f eq "ncftpget"){
$chdir = "cd $aslocal_dir && ";
$stdout_redir = "";
}
$CPAN::Frontend->myprint(
qq[
-Trying with "$funkyftp$source_switch" to get
+Trying with "$funkyftp$src_switch" to get
$url
]);
my($system) =
- "$chdir$funkyftp$source_switch '$url' $devnull$stdout_redir";
+ "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
$self->debug("system[$system]") if $CPAN::DEBUG;
my($wstatus);
if (($wstatus = system($system)) == 0
&&
($f eq "lynx" ?
- -s $aslocal_uncompressed # lynx returns 0 on my
+ -s $asl_ungz # lynx returns 0 on my
# system even if it fails
: 1
)
) {
if (-s $aslocal) {
# Looks good
- } elsif ($aslocal_uncompressed ne $aslocal) {
+ } elsif ($asl_ungz ne $aslocal) {
# test gzip integrity
if (
- CPAN::Tarzip->gtest($aslocal_uncompressed)
+ CPAN::Tarzip->gtest($asl_ungz)
) {
- rename $aslocal_uncompressed, $aslocal;
+ rename $asl_ungz, $aslocal;
} else {
- CPAN::Tarzip->gzip($aslocal_uncompressed,
- "$aslocal_uncompressed.gz");
+ CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
}
}
$Thesite = $i;
return $aslocal;
- } elsif ($url !~ /\.gz\z/) {
- unlink $aslocal_uncompressed if
- -f $aslocal_uncompressed && -s _ == 0;
+ } elsif ($url !~ /\.gz$/) {
+ unlink $asl_ungz if
+ -f $asl_ungz && -s _ == 0;
my $gz = "$aslocal.gz";
my $gzurl = "$url.gz";
$CPAN::Frontend->myprint(
qq[
-Trying with "$funkyftp$source_switch" to get
+Trying with "$funkyftp$src_switch" to get
$url.gz
]);
- my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ".
- "$aslocal_uncompressed.gz";
+ my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_gz";
$self->debug("system[$system]") if $CPAN::DEBUG;
my($wstatus);
if (($wstatus = system($system)) == 0
&&
- -s "$aslocal_uncompressed.gz"
+ -s $asl_gz
) {
# test gzip integrity
- if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
- CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
- $aslocal);
+ if (CPAN::Tarzip->gtest($asl_gz)) {
+ CPAN::Tarzip->gunzip($asl_gz,$aslocal);
} else {
- rename $aslocal_uncompressed, $aslocal;
+ rename $asl_ungz, $aslocal;
}
$Thesite = $i;
return $aslocal;
} else {
- unlink "$aslocal_uncompressed.gz" if
- -f "$aslocal_uncompressed.gz";
+ unlink $asl_gz if -f $asl_gz;
}
} else {
my $estatus = $wstatus >> 8;
@@ -2605,7 +2675,11 @@ sub cpl {
#-> sub CPAN::Complete::cplx ;
sub cplx {
my($class, $word) = @_;
- grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
+ # I believed for many years that this was sorted, today I
+ # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
+ # make it sorted again. Maybe sort was dropped when GNU-readline
+ # support came in? The RCS file is difficult to read on that:-(
+ sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
}
#-> sub CPAN::Complete::cpl_any ;
@@ -2785,10 +2859,29 @@ sub rd_modpacks {
unshift @ls, "\n" x length($1) if /^(\n+)/;
push @lines, @ls;
}
+ # read header
+ my $line_count;
while (@lines) {
my $shift = shift(@lines);
+ $shift =~ /^Line-Count:\s+(\d+)/;
+ $line_count = $1 if $1;
last if $shift =~ /^\s*$/;
}
+ if (not defined $line_count) {
+ warn 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;
+ } elsif ($line_count != scalar @lines) {
+
+ warn 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);
+
+ }
foreach (@lines) {
chomp;
my($mod,$version,$dist) = split;
@@ -3078,11 +3171,11 @@ sub get {
$self->debug("Changed directory to tmp") if $CPAN::DEBUG;
if (! $local_file) {
Carp::croak "bad download, can't do anything :-(\n";
- } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)\z/i){
+ } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)$/i){
$self->untar_me($local_file);
- } elsif ( $local_file =~ /\.zip\z/i ) {
+ } elsif ( $local_file =~ /\.zip$/i ) {
$self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)\z/) {
+ } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
@@ -3093,7 +3186,7 @@ sub get {
# Let's check if the package has its own directory.
my $dh = DirHandle->new(File::Spec->curdir)
or Carp::croak("Couldn't opendir .: $!");
- my @readdir = grep $_ !~ /^\.\.?\z/s, $dh->read; ### MAC??
+ my @readdir = grep $_ !~ /^\.\.?$/s, $dh->read; ### MAC??
$dh->close;
my ($distdir,$packagedir);
if (@readdir == 1 && -d $readdir[0]) {
@@ -3170,9 +3263,15 @@ sub untar_me {
sub unzip_me {
my($self,$local_file) = @_;
+ if ($CPAN::META->has_inst("Archive::Zip")) {
+ $CPAN::Frontend->mywarn("Archive::Zip not yet supported. ".
+ "Will use external unzip");
+ }
+ my $unzip = $CPAN::Config->{unzip} or
+ $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
$self->{archived} = "zip";
- my $system = "$CPAN::Config->{unzip} $local_file";
- if (system($system) == 0) {
+ my @system = ($unzip, $local_file);
+ if (system(@system) == 0) {
$self->{unwrapped} = "YES";
} else {
$self->{unwrapped} = "NO";
@@ -3183,7 +3282,7 @@ sub pm2dir_me {
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)\z//;
+ $to =~ s/\.(gz|Z)$//;
if (CPAN::Tarzip->gunzip($local_file,$to)) {
$self->{unwrapped} = "YES";
} else {
@@ -3246,7 +3345,7 @@ sub cvs_import {
my $userid = $self->{CPAN_USERID};
my $cvs_dir = (split '/', $dir)[-1];
- $cvs_dir =~ s/-\d+[^-]+\z//;
+ $cvs_dir =~ s/-\d+[^-]+$//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
my $cvs_site_perl =
@@ -3267,7 +3366,7 @@ sub cvs_import {
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
$CPAN::Frontend->myprint(qq{@cmd\n});
- system(@cmd) == 0 or
+ system(@cmd) == 0 or
$CPAN::Frontend->mydie("cvs import failed");
chdir($pwd);
}
@@ -3343,7 +3442,7 @@ sub verifyMD5 {
$lc_file = CPAN::FTP->localize("authors/id/@local",
"$lc_want.gz",1);
if ($lc_file) {
- $lc_file =~ s/\.gz\z//;
+ $lc_file =~ s/\.gz$//;
CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
} else {
return;
@@ -3401,7 +3500,7 @@ sub MD5_check_file {
$CPAN::Frontend->myprint("Checksum for $file ok\n");
return $self->{MD5_STATUS} = "OK";
} else {
- $CPAN::Frontend->myprint(qq{Checksum mismatch for }.
+ $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
qq{distribution file. }.
qq{Please investigate.\n\n}.
$self->as_string,
@@ -3409,10 +3508,12 @@ sub MD5_check_file {
'CPAN::Author',
$self->{CPAN_USERID}
)->as_string);
- my $wrap = qq{I\'d recommend removing $file. It seems to
-be a bogus file. Maybe you have configured your \`urllist\' with a
-bad URL. Please check this array with \`o conf urllist\', and
+
+ my $wrap = qq{I\'d recommend removing $file. Its MD5
+checksum is incorrect. Maybe you have configured your \`urllist\' with
+a bad URL. Please check this array with \`o conf urllist\', and
retry.};
+
$CPAN::Frontend->myprint(Text::Wrap::wrap("","",$wrap));
$CPAN::Frontend->myprint("\n\n");
sleep 3;
@@ -3460,15 +3561,21 @@ sub force {
}
}
+#-> sub CPAN::Distribution::isa_perl ;
sub isa_perl {
my($self) = @_;
my $file = File::Basename::basename($self->id);
return unless $file =~ m{ ^ perl
+ -?
(5)
([._-])
- (\d{3}(_[0-4][0-9])?)
+ (
+ \d{3}(_[0-4][0-9])?
+ |
+ \d*[24680]\.\d+
+ )
\.tar[._-]gz
- \z
+ $
}xs;
"$1.$3";
}
@@ -3507,7 +3614,8 @@ sub make {
if (
$self->called_for ne $self->id && ! $self->{'force_update'}
) {
- $CPAN::Frontend->mydie(sprintf qq{
+ # 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
@@ -3523,6 +3631,7 @@ or
$self->isa_perl,
$self->called_for,
$self->id);
+ sleep 5; return;
}
}
$self->get;
@@ -3635,7 +3744,8 @@ of modules we are processing right now?", "yes");
$follow = $answer =~ /^\s*y/i;
} else {
local($") = ", ";
- $CPAN::Frontend->myprint(" Ignoring dependencies on modules @prereq\n");
+ $CPAN::Frontend->
+ myprint(" Ignoring dependencies on modules @prereq\n");
}
if ($follow) {
CPAN::Queue->jumpqueue(@prereq,$id); # requeue yourself
@@ -3661,7 +3771,9 @@ sub needs_prereq {
$CPAN::Frontend->mydie("Couldn't open Makefile: $!");
local($/) = "\n";
- my(@p,@need);
+ # A.Speer @p -> %p, where %p is $p{Module::Name}=Required_Version
+ #
+ my(%p,@need);
while (<$fh>) {
last if /MakeMaker post_initialize section/;
my($p) = m{^[\#]
@@ -3670,23 +3782,43 @@ sub needs_prereq {
next unless $p;
# warn "Found prereq expr[$p]";
- while ( $p =~ m/(?:\s)([\w\:]+)=>q\[.*?\],?/g ){
- push @p, $1;
+ # Regexp modified by A.Speer to remember actual version of file
+ # PREREQ_PM hash key wants, then add to
+ while ( $p =~ m/(?:\s)([\w\:]+)=>q\[(.*?)\],?/g ){
+ # In case a prereq is mentioned twice, complain.
+ if ( defined $p{$1} ) {
+ warn "Warning: PREREQ_PM mentions $1 more than once, last mention wins";
+ }
+ $p{$1} = $2;
}
last;
}
- for my $p (@p) {
- my $mo = $CPAN::META->instance("CPAN::Module",$p);
- next if $mo->uptodate;
- # it's not needed, so don't push it. We cannot omit this step, because
- # if 'force' is in effect, nobody else will check.
- if ($self->{have_sponsored}{$p}++){
+ NEED: while (my($module, $need_version) = each %p) {
+ my $mo = $CPAN::META->instance("CPAN::Module",$module);
+ # we were too demanding:
+ # next if $mo->uptodate;
+
+ # 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.
+ {
+ local($^W) = 0;
+ if (defined $mo->inst_file &&
+ $mo->inst_version >= $need_version){
+ CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
+ $mo->inst_file, $mo->inst_version, $need_version
+ );
+ next NEED;
+ }
+ }
+
+ if ($self->{have_sponsored}{$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, $p;
+ push @need, $module;
}
return @need;
}
@@ -3973,14 +4105,36 @@ explicitly a file $s.
sleep 3;
}
# possibly noisy action:
+ $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
my $obj = $CPAN::META->instance($type,$s);
$obj->$meth();
- my $success = $obj->can("uptodate") ? $obj->uptodate : 0;
- $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
- $fail{$s} = 1 unless $success;
+ if ($obj->isa(CPAN::Bundle)
+ &&
+ exists $obj->{install_failed}
+ &&
+ ref($obj->{install_failed}) eq "HASH"
+ ) {
+ for (keys %{$obj->{install_failed}}) {
+ $self->{install_failed}{$_} = undef; # propagate faiure up
+ # to me in a
+ # recursive call
+ $fail{$s} = 1; # the bundle itself may have succeeded but
+ # not all children
+ }
+ } else {
+ my $success;
+ $success = $obj->can("uptodate") ? $obj->uptodate : 0;
+ $success ||= $obj->{'install'} && $obj->{'install'} eq "YES";
+ if ($success) {
+ delete $self->{install_failed}{$s};
+ } else {
+ $fail{$s} = 1;
+ }
+ }
}
+
# recap with less noise
- if ( $meth eq "install") {
+ if ( $meth eq "install" ) {
if (%fail) {
require Text::Wrap;
my $raw = sprintf(qq{Bundle summary:
@@ -3990,9 +4144,21 @@ The following items in bundle %s had installation problems:},
$CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
$CPAN::Frontend->myprint("\n");
my $paragraph = "";
+ my %reported;
for $s ($self->contains) {
- $paragraph .= "$s " if $fail{$s};
+ if ($fail{$s}){
+ $paragraph .= "$s ";
+ $self->{install_failed}{$s} = undef;
+ $reported{$s} = undef;
+ }
}
+ my $report_propagated;
+ for $s (sort keys %{$self->{install_failed}}) {
+ next if exists $reported{$s};
+ $paragraph .= "and the following items had problems
+during recursive bundle calls: " unless $report_propagated++;
+ $paragraph .= "$s ";
+ }
$CPAN::Frontend->myprint(Text::Wrap::fill(" "," ",$paragraph));
$CPAN::Frontend->myprint("\n");
} else {
@@ -4124,7 +4290,7 @@ sub as_string {
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
- $local_file =~ s/\.pm\z/.pod/;
+ $local_file =~ s/\.pm$/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
@@ -4305,13 +4471,26 @@ sub inst_version {
my $parsefile = $self->inst_file or return;
local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
# warn "HERE";
- my $have = MM->parse_version($parsefile) || "undef";
+ my $have;
+ # local($SIG{__WARN__}) = sub { warn "1. have[$have]"; };
+
+ # there was a bug in 5.6.0 that let lots of unini warnings out of
+ # parse_version. Fixed shortly after 5.6.0 by PMQS. We can remove
+ # this workaround after 5.6.1 is out.
+ local($SIG{__WARN__}) = sub { my $w = shift;
+ return if $w =~ /uninitialized/i;
+ warn $w;
+ };
+ $have = MM->parse_version($parsefile) || "undef";
+ # local($SIG{__WARN__}) = sub { warn "2. have[$have]"; };
$have =~ s/\s*//g; # stringify to float around floating point issues
- $have;
+ # local($SIG{__WARN__}) = sub { warn "3. have[$have]"; };
+ $have; # no stringify needed, \s* above matches always
}
package CPAN::Tarzip;
+# CPAN::Tarzip::gzip
sub gzip {
my($class,$read,$write) = @_;
if ($CPAN::META->has_inst("Compress::Zlib")) {
@@ -4330,6 +4509,8 @@ sub gzip {
}
}
+
+# CPAN::Tarzip::gunzip
sub gunzip {
my($class,$read,$write) = @_;
if ($CPAN::META->has_inst("Compress::Zlib")) {
@@ -4350,6 +4531,8 @@ sub gunzip {
}
}
+
+# CPAN::Tarzip::gtest
sub gtest {
my($class,$read) = @_;
if ($CPAN::META->has_inst("Compress::Zlib")) {
@@ -4357,15 +4540,18 @@ sub gtest {
my $gz = Compress::Zlib::gzopen($read, "rb")
or $CPAN::Frontend->mydie("Cannot open $read: $!\n");
1 while $gz->gzread($buffer) > 0 ;
- $CPAN::Frontend->mydie("Error reading from $read: $!\n")
- if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
- $gz->gzclose() ;
- return 1;
+ my $err = $gz->gzerror;
+ my $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
+ $gz->gzclose();
+ $class->debug("err[$err]success[$success]") if $CPAN::DEBUG;
+ return $success;
} else {
return system("$CPAN::Config->{'gzip'} -dt $read")==0;
}
}
+
+# CPAN::Tarzip::TIEHANDLE
sub TIEHANDLE {
my($class,$file) = @_;
my $ret;
@@ -4383,6 +4569,8 @@ sub TIEHANDLE {
$ret;
}
+
+# CPAN::Tarzip::READLINE
sub READLINE {
my($self) = @_;
if (exists $self->{GZ}) {
@@ -4397,6 +4585,8 @@ sub READLINE {
}
}
+
+# CPAN::Tarzip::READ
sub READ {
my($self,$ref,$length,$offset) = @_;
die "read with offset not implemented" if defined $offset;
@@ -4410,6 +4600,8 @@ sub READ {
}
}
+
+# CPAN::Tarzip::DESTROY
sub DESTROY {
my($self) = @_;
if (exists $self->{GZ}) {
@@ -4422,6 +4614,8 @@ sub DESTROY {
undef $self;
}
+
+# CPAN::Tarzip::untar
sub untar {
my($class,$file) = @_;
# had to disable, because version 0.07 seems to be buggy
@@ -4441,7 +4635,7 @@ sub untar {
qq{Couldn\'t uncompress $file\n}
);
}
- $file =~ s/\.gz\z//;
+ $file =~ s/\.gz$//;
$system = "$CPAN::Config->{tar} xvf $file";
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
if (system($system)==0) {
@@ -4584,10 +4778,10 @@ also is run unconditionally. But for
CPAN checks if an install is actually needed for it and prints
I<module up to date> in the case that the distribution file containing
-the module doesnE<39>t need to be updated.
+the module doesn't need to be updated.
CPAN also keeps track of what it has done within the current session
-and doesnE<39>t try to build a package a second time regardless if it
+and doesn't try to build a package a second time regardless if it
succeeded or not. The C<force> command takes as a first argument the
method to invoke (currently: C<make>, C<test>, or C<install>) and executes the
command from scratch.
@@ -4659,7 +4853,7 @@ installation. You start on one architecture with the help of a Bundle
file produced earlier. CPAN installs the whole Bundle for you, but
when you try to repeat the job on the second architecture, CPAN
responds with a C<"Foo up to date"> message for all modules. So you
-invoke CPAN's recompile on the second architecture and youE<39>re done.
+invoke CPAN's recompile on the second architecture and you're done.
Another popular use for C<recompile> is to act as a rescue in case your
perl breaks binary compatibility. If one of the modules that CPAN uses
@@ -4704,7 +4898,7 @@ so you would have to say
The first example will be driven by an object of the class
CPAN::Module, the second by an object of class CPAN::Distribution.
-=head2 ProgrammerE<39>s interface
+=head2 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
@@ -4749,8 +4943,11 @@ functionalities that are available in the shell.
print "No VERSION in ", $mod->id, "\n";
}
+ # find out which distribution on CPAN contains a module:
+ print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
+
Or if you want to write a cronjob to watch The CPAN, you could list
-all modules that need updating:
+all modules that need updating. First a quick and dirty way:
perl -e 'use CPAN; CPAN::Shell->r;'
@@ -4919,6 +5116,8 @@ defined:
build_dir locally accessible directory to build modules
index_expire after this many days refetch index files
cpan_home local directory reserved for this package
+ dontload_hash anonymous hash: modules in the keys will not be
+ loaded by the CPAN::has_inst() routine
gzip location of external program gzip
inactivity_timeout breaks interactive Makefile.PLs after this
many seconds inactivity. Set to 0 to never break.
@@ -5048,7 +5247,13 @@ unattained.
=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
Thanks to Graham Barr for contributing the following paragraphs about
-the interaction between perl, and various firewall configurations.
+the interaction between perl, and various firewall configurations. For
+further informations on firewalls, it is recommended to consult the
+documentation that comes with the ncftp program. If you are unable to
+go through the firewall with a simple Perl setup, it is very likely
+that you can configure ncftp so that it works for your firewall.
+
+=head2 Three basic types of firewalls
Firewalls can be categorized into three basic types.
@@ -5105,6 +5310,59 @@ special compiling is need as you can access hosts directly.
=back
+=head2 Configuring lynx or ncftp for going throught the firewall
+
+If you can go through your firewall with e.g. lynx, presumably with a
+command such as
+
+ /usr/local/bin/lynx -pscott:tiger
+
+then you would configure CPAN.pm with the command
+
+ o conf lynx "/usr/local/bin/lynx -pscott:tiger"
+
+That's all. Similarly for ncftp or ftp, you would configure something
+like
+
+ o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
+
+Your milage may vary...
+
+=head1 FAQ
+
+=over
+
+=item I installed a new version of module X but CPAN keeps saying, I
+ have the old version installed
+
+Most probably you B<do> have the old version installed. This can
+happen if a module installs itself into a different directory in the
+@INC path than it was previously installed. This is not really a
+CPAN.pm problem, you would have the same problem when installing the
+module manually. The easiest way to prevent this behaviour is to add
+the argument C<UNINST=1> to the C<make install> call, and that is why
+many people add this argument permanently by configuring
+
+ o conf make_install_arg UNINST=1
+
+=item So why is UNINST=1 not the default?
+
+Because there are people who have their precise expectations about who
+may install where in the @INC path and who uses which @INC array. In
+fine tuned environments C<UNINST=1> can cause damage.
+
+=item When I install bundles or multiple modules with one command
+ there is too much output to keep track of
+
+You may want to configure something like
+
+ o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
+ o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
+
+so that STDOUT is captured in a file for later inspection.
+
+=back
+
=head1 BUGS
We should give coverage for B<all> of the CPAN and not just the PAUSE
diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm
index 0e795da4fb..9bd12f3ea2 100644
--- a/lib/CPAN/FirstTime.pm
+++ b/lib/CPAN/FirstTime.pm
@@ -16,7 +16,7 @@ use FileHandle ();
use File::Basename ();
use File::Path ();
use vars qw($VERSION);
-$VERSION = substr q$Revision: 1.38 $, 10;
+$VERSION = substr q$Revision: 1.40 $, 10;
=head1 NAME
@@ -149,7 +149,7 @@ next question.
print qq{
How big should the disk cache be for keeping the build directories
-with all the intermediate files?
+with all the intermediate files\?
};
@@ -188,7 +188,7 @@ policy to one of the three values.
};
- $default = $CPAN::Config->{prerequisites_policy} || 'follow';
+ $default = $CPAN::Config->{prerequisites_policy} || 'ask';
do {
$ans =
prompt("Policy on building prerequisites (follow, ask or ignore)?",
@@ -361,7 +361,8 @@ sub conf_sites {
File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
}
my $loopcount = 0;
- while () {
+ local $^T = time;
+ while ($mby) {
if ( ! -f $mby ){
print qq{You have no $mby
I\'m trying to fetch one
@@ -383,6 +384,7 @@ sub conf_sites {
}
}
read_mirrored_by($mby);
+ bring_your_own();
}
sub find_exe {
@@ -424,7 +426,7 @@ sub picklist {
}
sub read_mirrored_by {
- my($local) = @_;
+ my $local = shift or return;
my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location);
my $fh = FileHandle->new;
$fh->open($local) or die "Couldn't open $local: $!";
@@ -512,25 +514,33 @@ http: -- that host a CPAN mirror.
@urls = picklist (\@urls, $prompt, $default);
foreach (@urls) { s/ \(.*\)//; }
- %seen = map (($_ => 1), @urls);
+ push @{$CPAN::Config->{urllist}}, @urls;
+}
+sub bring_your_own {
+ my %seen = map (($_ => 1), @{$CPAN::Config->{urllist}});
+ my($ans,@urls);
do {
- $ans = prompt ("Enter another URL or RETURN to quit:", "");
+ my $prompt = "Enter another URL or RETURN to quit:";
+ unless (%seen) {
+ $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.
+
+Please enter your CPAN site:};
+ }
+ $ans = prompt ($prompt, "");
if ($ans) {
- $ans =~ s|/?$|/|; # has to end with one slash
+ $ans =~ s|/?\z|/|; # has to end with one slash
$ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
if ($ans =~ /^\w+:\/./) {
- push @urls, $ans
- unless $seen{$ans};
- }
- else {
+ push @urls, $ans unless $seen{$ans}++;
+ } else {
print qq{"$ans" doesn\'t look like an URL at first sight.
I\'ll ignore it for now. You can add it to $INC{'CPAN/MyConfig.pm'}
later if you\'re sure it\'s right.\n};
}
}
- } while $ans;
+ } while $ans || !%seen;
push @{$CPAN::Config->{urllist}}, @urls;
# xxx delete or comment these out when you're happy that it works
View Lorry Controller Status