use vars qw{$Try_autoload
$Revision
$META $Signal $Cwd $End
- $Suppress_readline %Dontload
+ $Suppress_readline
$Frontend $Defaultsite
}; #};
-$VERSION = '1.50';
+$VERSION = '1.57';
-# $Id: CPAN.pm,v 1.264 1999/05/23 14:26:49 k Exp $
+# $Id: CPAN.pm,v 1.305 2000/08/16 12:42:32 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.264 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.305 $, 10)."]";
use Carp ();
use Config ();
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; }
$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);
@EXPORT = qw(
- autobundle bundle expand force get
+ autobundle bundle expand force get cvs_import
install make readme recompile shell test clean
);
#-> sub CPAN::shell ;
sub shell {
my($self) = @_;
- $Suppress_readline ||= ! -t STDIN;
+ $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
CPAN::Config->load unless $CPAN::Config_loaded++;
my $prompt = "cpan> ";
$readline::rl_completion_function =
$readline::rl_completion_function = 'CPAN::Complete::cpl';
}
+ # $term->OUT is autoflushed anyway
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
}
no strict;
my $getcwd;
$getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $cwd = CPAN->$getcwd();
- my $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub";
+ my $try_detect_readline;
+ $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
my $rl_avail = $Suppress_readline ? "suppressed" :
($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
"available (try ``install Bundle::CPAN'')";
my $command = shift @line;
eval { CPAN::Shell->$command(@line) };
warn $@ if $@;
- chdir $cwd;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
$CPAN::Frontend->myprint("\n");
$continuation = "";
$prompt = "cpan> ";
my $redef;
local($SIG{__WARN__}) = CPAN::Shell::dotdot_onreload(\$redef);
require Term::ReadLine;
- $CPAN::Frontend->myprint("\n$redef subroutines in Term::ReadLine redefined\n");
+ $CPAN::Frontend->myprint("\n$redef subroutines in ".
+ "Term::ReadLine redefined\n");
goto &shell;
}
}
$pkg =~ s|::|/|g;
if (defined($name=$INC{"$pkg.pm"}))
{
- $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|;
+ $name =~ s|^(.*)$pkg\.pm(?!\n)\Z|$1auto/$pkg/$func.al|s;
$name = undef unless (-r $name);
}
unless (defined $name)
*$autoload = sub {};
$ok = 1;
} else {
- if ($name =~ s{(\w{12,})\.al$}{substr($1,0,11).".al"}e){
+ if ($name =~ s{(\w{12,})\.al(?!\n)\Z}{substr($1,0,11).".al"}e){
eval {local $SIG{__DIE__};require $name};
}
if ($@){
}
my $fh;
unless ($fh = FileHandle->new(">$lockfile")) {
- if ($! =~ /Permission/ || $!{EACCES}) {
+ if ($! =~ /Permission/) {
my $incc = $INC{'CPAN/Config.pm'};
my $myincc = MM->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
$CPAN::Frontend->myprint(qq{
print "Caught SIGINT\n";
$Signal++;
};
+
+# From: Larry Wall <larry@wall.org>
+# Subject: Re: deprecating SIGDIE
+# To: perl5-porters@perl.org
+# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
+#
+# The original intent of __DIE__ was only to allow you to substitute one
+# kind of death for another on an application-wide basis without respect
+# to whether you were in an eval or not. As a global backstop, it should
+# not be used any more lightly (or any more heavily :-) than class
+# UNIVERSAL. Any attempt to build a general exception model on it should
+# be politely squashed. Any bug that causes every eval {} to have to be
+# modified should be not so politely squashed.
+#
+# Those are my current opinions. It is also my optinion that polite
+# arguments degenerate to personal arguments far too frequently, and that
+# when they do, it's because both people wanted it to, or at least didn't
+# sufficiently want it not to.
+#
+# Larry
+
$SIG{'__DIE__'} = \&cleanup;
$self->debug("Signal handler set.") if $CPAN::DEBUG;
}
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;
if ($^O eq 'MacOS') {
require Mac::Files;
my $cat = Mac::Files::FSpGetCatInfo($_);
- $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen();
+ $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
} else {
$Du += (-s _);
}
package CPAN::Config;
#-> sub CPAN::Config::edit ;
+# returns true on successful action
sub edit {
my($class,@args) = @_;
return unless @args;
$class->$o(@args);
return 1;
} else {
- if (ref($CPAN::Config->{$o}) eq ARRAY) {
+ CPAN->debug("o[$o]") if $CPAN::DEBUG;
+ if ($o =~ /list$/) {
$func = shift @args;
$func ||= "";
+ CPAN->debug("func[$func]") if $CPAN::DEBUG;
+ 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 "",
"\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 " .
}
}
- 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
commit commit session changes to disk
init go through a dialog to set all parameters
-You may edit key values in the follow fashion:
+You may edit key values in the follow fashion (the "o" is a literal
+letter o):
o conf build_cache 15
$CPAN::Frontend->myprint("Detailed help not yet implemented\n");
} else {
$CPAN::Frontend->myprint(q{
-command arguments description
-a string authors
-b or display bundles
-d /regex/ info distributions
-m or about modules
-i none anything of above
-
-r as reinstall recommendations
-u above uninstalled distributions
-See manpage for autobundle, recompile, force, look, etc.
-
-make make
-test modules, make test (implies make)
-install dists, bundles, make install (implies test)
-clean "r" or "u" make clean
-readme display the README file
-
-reload index|cpan load most recent indices/CPAN.pm
-h or ? display this menu
-o various set and query options
-! perl-code eval a perl command
-q quit the shell subroutine
-});
+Display Information
+ a authors
+ b string display bundles
+ d or info distributions
+ m /regex/ about modules
+ i or anything of above
+ r none reinstall recommendations
+ u uninstalled distributions
+
+Download, Test, Make, Install...
+ get download
+ make make (implies get)
+ test modules, make test (implies make)
+ install dists, bundles make install (implies test)
+ clean make clean
+ look open subshell in these dists' directories
+ readme display these dists' README files
+
+Other
+ h,? display this menu ! perl-code eval a perl command
+ 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 force cmd unconditionally do cmd});
}
}
*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) = @_;
my($entry);
for $entry ($dh->read) {
next if -d MM->catdir($bdir,$entry);
- next unless $entry =~ s/\.pm$//;
+ next unless $entry =~ s/\.pm(?!\n)\Z//;
$CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
}
}
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(
"",
" %-18s\n",
$k
),
- map {"\t$_\n"} @{$v}
+ map {"\t$_\n"} @report
)
);
} else {
}
}
} else {
- $CPAN::Frontend->myprint("Valid options for debug are ".
- join(", ",sort(keys %CPAN::DEBUG), 'all').
- qq{ or a number. Completion works on the options. }.
- qq{Case is ignored.\n\n});
+ my $raw = "Valid options for debug are ".
+ join(", ",sort(keys %CPAN::DEBUG), 'all').
+ qq{ or a number. Completion works on the options. }.
+ qq{Case is ignored.};
+ require Text::Wrap;
+ $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
+ $CPAN::Frontend->myprint("\n\n");
}
if ($CPAN::DEBUG) {
$CPAN::Frontend->myprint("Options set for debugging:\n");
my($k,$v);
for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
$v = $CPAN::DEBUG{$k};
- $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v) if $v & $CPAN::DEBUG;
+ $CPAN::Frontend->myprint(sprintf " %-14s(%s)\n", $k, $v)
+ if $v & $CPAN::DEBUG;
}
} else {
$CPAN::Frontend->myprint("Debugging turned off completely.\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$};
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;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
+ next if $dist->isa_perl;
next unless $module->xs_file;
local($|) = 1;
$CPAN::Frontend->myprint(".");
for $module ($self->expand('Module',@args)) {
my $file = $module->cpan_file;
next unless defined $file; # ??
- my($latest) = $module->cpan_version;
+ my($latest) = $module->cpan_version; # %vd
my($inst_file) = $module->inst_file;
my($have);
return if $CPAN::Signal;
if ($inst_file){
if ($what eq "a") {
- $have = $module->inst_version;
+ $have = $module->inst_version; # %vd
} elsif ($what eq "r") {
- $have = $module->inst_version;
+ $have = $module->inst_version; # %vd
local($^W) = 0;
if ($have eq "undef"){
$version_undefs++;
"in CPAN file"
));
}
- $latest = substr($latest,0,8) if length($latest) > 8;
- $have = substr($have,0,8) if length($have) > 8;
- $CPAN::Frontend->myprint(sprintf $sprintf, $module->id, $have, $latest, $file);
+ for ($have,$latest) {
+ if ($] >= 5.006) { # people start using v-strings
+ local($^W) = 0;
+ unless (/^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
+ && "$2$4" ne ""
+ ||
+ /^undef$/
+ ||
+ /^-$/ # not installed
+ ) {
+ $_ = sprintf "%vd", $_;
+ }
+ }
+ $_ = substr($_,0,8) if length($_) > 8;
+ }
+ $CPAN::Frontend->myprint(sprintf $sprintf,
+ $module->id,
+ $have,
+ $latest,
+ $file);
$need{$module->id}++;
}
unless (%need) {
my $class = "CPAN::$type";
my $obj;
if (defined $regex) {
- for $obj ( sort {$a->id cmp $b->id} $CPAN::META->all_objects($class)) {
- push @m, $obj
- if
- $obj->id =~ /$regex/i
- or
+ for $obj (
+ sort
+ {$a->id cmp $b->id}
+ $CPAN::META->all_objects($class)
+ ) {
+ unless ($obj->id){
+ # BUG, we got an empty object somewhere
+ CPAN->debug(sprintf(
+ "Empty id on obj[%s]%%[%s]",
+ $obj,
+ join(":", %$obj)
+ )) if $CPAN::DEBUG;
+ next;
+ }
+ push @m, $obj
+ if $obj->id =~ /$regex/i
+ or
(
(
- $] < 5.00303 ### provide sort of compatibility with 5.003
+ $] < 5.00303 ### provide sort of
+ ### compatibility with 5.003
||
$obj->can('name')
)
&&
$obj->name =~ /$regex/i
);
- }
+ }
} else {
my($xarg) = $arg;
if ( $type eq 'Bundle' ) {
die "\n";
}
+sub setup_output {
+ return if -t STDOUT;
+ my $odef = select STDERR;
+ $| = 1;
+ select STDOUT;
+ $| = 1;
+ select $odef;
+}
+
#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall
sub rematein {
$pragma = $meth;
$meth = shift @some;
}
+ setup_output();
CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
my($s,@s);
foreach $s (@some) {
sub clean { shift->rematein('clean',@_); }
#-> sub CPAN::Shell::look ;
sub look { shift->rematein('look',@_); }
+#-> sub CPAN::Shell::cvs_import ;
+sub cvs_import { shift->rematein('cvs_import',@_); }
package CPAN::FTP;
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);
my $ret = $self->$method(\@host_seq,$file,$aslocal);
if ($ret) {
$Themethod = $level;
+ my $now = time;
+ # utime $now, $now, $aslocal; # too bad, if we do that, we
+ # might alter a local mirror
$self->debug("level[$level]") if $CPAN::DEBUG;
return $ret;
} else {
$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
$l =~ s|^file:||; # assume they
# meant
# file://localhost
- $l =~ s|^/|| unless -f $l; # e.g. /P:
+ $l =~ s|^/||s unless -f $l; # e.g. /P:
}
if ( -f $l && -r _) {
$Thesite = $i;
}
}
}
- if ($CPAN::META->has_inst('LWP')) {
+ if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
");
my $res = $Ua->mirror($url, $aslocal);
if ($res->is_success) {
$Thesite = $i;
+ my $now = time;
+ utime $now, $now, $aslocal; # download time is more
+ # important than upload time
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
my $gzurl = "$url.gz";
$CPAN::Frontend->myprint("Fetching with LWP:
$gzurl
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
$Thesite = $i;
return $aslocal;
}
- if ($aslocal !~ /\.gz$/) {
+ if ($aslocal !~ /\.gz(?!\n)\Z/) {
my $gz = "$aslocal.gz";
$CPAN::Frontend->myprint("Fetching with Net::FTP
$url.gz
HOSTHARD: for $i (@$host_seq) {
my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
unless ($self->is_reachable($url)) {
- $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
- next;
+ $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
+ next;
}
$url .= "/" unless substr($url,-1) eq "/";
$url .= $file;
# if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
# to
if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
- # proto not yet used
- ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
+ # proto not yet used
+ ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
} else {
- next HOSTHARD; # who said, we could ftp anything except ftp?
+ next HOSTHARD; # who said, we could ftp anything except ftp?
}
+
$self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
my($f,$funkyftp);
for $f ('lynx','ncftpget','ncftp') {
- next unless exists $CPAN::Config->{$f};
- $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) = "";
- $source_switch = " -source" if $funkyftp =~ /\blynx$/;
- $source_switch = " -c" if $funkyftp =~ /\bncftp$/;
- $CPAN::Frontend->myprint(
- qq[
-Trying with "$funkyftp$source_switch" to get
+ next unless exists $CPAN::Config->{$f};
+ $funkyftp = $CPAN::Config->{$f};
+ next unless defined $funkyftp;
+ next if $funkyftp =~ /^\s*$/;
+ my($asl_ungz, $asl_gz);
+ ($asl_ungz = $aslocal) =~ s/\.gz//;
+ $asl_gz = "$asl_ungz.gz";
+ my($src_switch) = "";
+ if ($f eq "lynx"){
+ $src_switch = " -source";
+ } elsif ($f eq "ncftp"){
+ $src_switch = " -c";
+ }
+ my($chdir) = "";
+ my($stdout_redir) = " > $asl_ungz";
+ if ($f eq "ncftpget"){
+ $chdir = "cd $aslocal_dir && ";
+ $stdout_redir = "";
+ }
+ $CPAN::Frontend->myprint(
+ qq[
+Trying with "$funkyftp$src_switch" to get
$url
]);
- my($system) = "$funkyftp$source_switch '$url' $devnull > ".
- "$aslocal_uncompressed";
+ my($system) =
+ "$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 $asl_ungz # lynx returns 0 on my
+ # system even if it fails
+ : 1
+ )
+ ) {
+ if (-s $aslocal) {
+ # Looks good
+ } elsif ($asl_ungz ne $aslocal) {
+ # test gzip integrity
+ if (
+ CPAN::Tarzip->gtest($asl_ungz)
+ ) {
+ rename $asl_ungz, $aslocal;
+ } else {
+ CPAN::Tarzip->gzip($asl_ungz,$asl_gz);
+ }
+ }
+ $Thesite = $i;
+ return $aslocal;
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
+ unlink $asl_ungz if
+ -f $asl_ungz && -s _ == 0;
+ my $gz = "$aslocal.gz";
+ my $gzurl = "$url.gz";
+ $CPAN::Frontend->myprint(
+ qq[
+Trying with "$funkyftp$src_switch" to get
+ $url.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 # lynx returns 0 on my
- # system even if it fails
+ -s $asl_gz
) {
- if ($aslocal_uncompressed ne $aslocal) {
- # test gzip integrity
- if (
- CPAN::Tarzip->gtest($aslocal_uncompressed)
- ) {
- rename $aslocal_uncompressed, $aslocal;
- } else {
- CPAN::Tarzip->gzip($aslocal_uncompressed,
- "$aslocal_uncompressed.gz");
- }
- }
- $Thesite = $i;
- return $aslocal;
- } elsif ($url !~ /\.gz$/) {
- unlink $aslocal_uncompressed if
- -f $aslocal_uncompressed && -s _ == 0;
- my $gz = "$aslocal.gz";
- my $gzurl = "$url.gz";
- $CPAN::Frontend->myprint(
- qq[
-Trying with "$funkyftp$source_switch" to get
- $url.gz
-]);
- my($system) = "$funkyftp$source_switch '$url.gz' $devnull > ".
- "$aslocal_uncompressed.gz";
- $self->debug("system[$system]") if $CPAN::DEBUG;
- my($wstatus);
- if (($wstatus = system($system)) == 0
- &&
- -s "$aslocal_uncompressed.gz"
- ) {
- # test gzip integrity
- if (CPAN::Tarzip->gtest("$aslocal_uncompressed.gz")) {
- CPAN::Tarzip->gunzip("$aslocal_uncompressed.gz",
- $aslocal);
- } else {
- rename $aslocal_uncompressed, $aslocal;
- }
- $Thesite = $i;
- return $aslocal;
+ # test gzip integrity
+ if (CPAN::Tarzip->gtest($asl_gz)) {
+ CPAN::Tarzip->gunzip($asl_gz,$aslocal);
} else {
- unlink "$aslocal_uncompressed.gz" if
- -f "$aslocal_uncompressed.gz";
+ rename $asl_ungz, $aslocal;
}
+ $Thesite = $i;
+ return $aslocal;
} else {
- my $estatus = $wstatus >> 8;
- my $size = -f $aslocal ? ", left\n$aslocal with size ".-s _ : "";
- $CPAN::Frontend->myprint(qq{
+ unlink $asl_gz if -f $asl_gz;
+ }
+ } else {
+ my $estatus = $wstatus >> 8;
+ my $size = -f $aslocal ?
+ ", left\n$aslocal with size ".-s _ :
+ "\nWarning: expected file [$aslocal] doesn't exist";
+ $CPAN::Frontend->myprint(qq{
System call "$system"
returned status $estatus (wstat $wstatus)$size
});
- }
+ }
}
}
}
next;
}
my($host,$dir,$getfile) = ($1,$2,$3);
- my($netrcfile,$fh);
my $timestamp = 0;
my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
$ctime,$blksize,$blocks) = stat($aslocal);
$timestamp = $mtime ||= 0;
my($netrc) = CPAN::FTP::netrc->new;
+ my($netrcfile) = $netrc->netrc;
my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
my $targetfile = File::Basename::basename($aslocal);
my(@dialog);
"get $getfile $targetfile",
"quit"
);
- if (! $netrc->netrc) {
+ if (! $netrcfile) {
CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
} elsif ($netrc->hasdefault || $netrc->contains($host)) {
CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
/^$word/,
sort qw(
! a b d h i m o q r u autobundle clean
- make test install force reload look
+ make test install force reload look cvs_import
)
);
- } elsif ( $line !~ /^[\!abdhimorutl]/ ) {
+ } elsif ( $line !~ /^[\!abcdhimorutl]/ ) {
@return = ();
} elsif ($line =~ /^a\s/) {
@return = cplx('CPAN::Author',$word);
@return = cplx('CPAN::Bundle',$word);
} elsif ($line =~ /^d\s/) {
@return = cplx('CPAN::Distribution',$word);
- } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look)\s/ ) {
+ } elsif ($line =~ /^([mru]|make|clean|test|install|readme|look|cvs_import)\s/ ) {
@return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
} elsif ($line =~ /^i\s/) {
@return = cpl_any($word);
#-> 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 ;
}
return if $last_time + $CPAN::Config->{index_expire}*86400 > $time
and ! $force;
+ ## IFF we are developing, it helps to wipe out the memory between
+ ## reloads, otherwise it is not what a user expects.
+
+ ## undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
+ ## $CPAN::META = CPAN->new;
my($debug,$t2);
$last_time = $time;
#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
- my($cl, $index_target) = @_;
+ my($self, $index_target) = @_;
my @lines;
return unless defined $index_target;
$CPAN::Frontend->myprint("Going to read $index_target\n");
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;
+ # 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
+ my($mod,$version,$dist,$comment) = split " ", $_, 4;
### $version =~ s/^\+//;
- # if it is a bundle, instatiate a bundle object
+ # if it is a bundle, instantiate a bundle object
my($bundle,$id,$userid);
if ($mod eq 'CPAN' &&
if ($version > $CPAN::VERSION){
$CPAN::Frontend->myprint(qq{
There\'s a new CPAN.pm version (v$version) available!
+ [Current version is v$CPAN::VERSION]
You might want to try
install Bundle::CPAN
reload cpan
}
if ($id->cpan_file ne $dist){
- $userid = $cl->userid($dist);
+ $userid = $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
- 'CPAN_VERSION' => $version,
- 'CPAN_FILE' => $dist
+ 'CPAN_VERSION' => $version, # %vd
+ 'CPAN_FILE' => $dist,
+ 'CPAN_COMMENT' => $comment,
);
}
# instantiate a distribution object
- unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
- $CPAN::META->instance(
- 'CPAN::Distribution' => $dist
- )->set(
- 'CPAN_USERID' => $userid
- );
+ if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ # we do not need CONTAINSMODS unless we do something with
+ # this dist, so we better produce it on demand.
+
+ ## my $obj = $CPAN::META->instance(
+ ## 'CPAN::Distribution' => $dist
+ ## );
+ ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
+ } else {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid
+ );
}
return if $CPAN::Signal;
$extra .= ")";
}
if (ref($self->{$_}) eq "ARRAY") { # language interface? XXX
- push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
+ push @m, sprintf " %-12s %s%s\n", $_, "@{$self->{$_}}", $extra;
+ } elsif (ref($self->{$_}) eq "HASH") {
+ push @m, sprintf(
+ " %-12s %s%s\n",
+ $_,
+ join(" ",keys %{$self->{$_}}),
+ $extra);
} else {
- push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
+ push @m, sprintf " %-12s %s%s\n", $_, $self->{$_}, $extra;
}
}
join "", @m, "\n";
package CPAN::Distribution;
+#-> sub CPAN::Distribution::as_string ;
+sub as_string {
+ my $self = shift;
+ $self->containsmods;
+ $self->SUPER::as_string(@_);
+}
+
+#-> sub CPAN::Distribution::containsmods ;
+sub containsmods {
+ my $self = shift;
+ return if exists $self->{CONTAINSMODS};
+ for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
+ my $mod_file = $mod->{CPAN_FILE} or next;
+ my $dist_id = $self->{ID} or next;
+ my $mod_id = $mod->{ID} or next;
+ $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
+ }
+}
+
#-> sub CPAN::Distribution::called_for ;
sub called_for {
my($self,$id) = @_;
$self->debug("Removing tmp") if $CPAN::DEBUG;
File::Path::rmtree("tmp");
mkdir "tmp", 0755 or Carp::croak "Couldn't mkdir tmp: $!";
- chdir "tmp";
+ chdir "tmp" or $CPAN::Frontend->mydie(qq{Could not chdir to "tmp": $!});;
$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)$/i){
+ } elsif ($local_file =~ /(\.tar\.(gz|Z)|\.tgz)(?!\n)\Z/i){
$self->untar_me($local_file);
- } elsif ( $local_file =~ /\.zip$/i ) {
+ } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
$self->unzip_me($local_file);
- } elsif ( $local_file =~ /\.pm\.(gz|Z)$/) {
+ } elsif ( $local_file =~ /\.pm\.(gz|Z)(?!\n)\Z/) {
$self->pm2dir_me($local_file);
} else {
$self->{archived} = "NO";
}
- chdir File::Spec->updir;
+ my $cwd = File::Spec->updir;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "": $!});
if ($self->{archived} ne 'NO') {
- chdir File::Spec->catdir(File::Spec->curdir, "tmp");
- # 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 $_ !~ /^\.\.?$/, $dh->read; ### MAC??
- $dh->close;
- my ($distdir,$packagedir);
- if (@readdir == 1 && -d $readdir[0]) {
- $distdir = $readdir[0];
- $packagedir = MM->catdir($builddir,$distdir);
- -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
- File::Path::rmtree($packagedir);
- rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
- } else {
- my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
- $pragmatic_dir =~ s/\W_//g;
- $pragmatic_dir++ while -d "../$pragmatic_dir";
- $packagedir = MM->catdir($builddir,$pragmatic_dir);
- File::Path::mkpath($packagedir);
- my($f);
- for $f (@readdir) { # is already without "." and ".."
- my $to = MM->catdir($packagedir,$f);
- rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
- }
- }
- $self->{'build_dir'} = $packagedir;
- chdir File::Spec->updir;
-
- $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
- if $CPAN::DEBUG;
- File::Path::rmtree("tmp");
- if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
- $CPAN::Frontend->myprint("Going to unlink $local_file\n");
- unlink $local_file or Carp::carp "Couldn't unlink $local_file";
- }
- my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
- unless (-f $makefilepl) {
- my($configure) = MM->catfile($packagedir,"Configure");
- if (-f $configure) {
- # do we have anything to do?
- $self->{'configure'} = $configure;
- } elsif (-f MM->catfile($packagedir,"Makefile")) {
- $CPAN::Frontend->myprint(qq{
+ $cwd = File::Spec->catdir(File::Spec->curdir, "tmp");
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+ # 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 $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
+ $dh->close;
+ my ($distdir,$packagedir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = MM->catdir($builddir,$distdir);
+ -d $packagedir and $CPAN::Frontend->myprint("Removing previously used $packagedir\n");
+ File::Path::rmtree($packagedir);
+ rename($distdir,$packagedir) or Carp::confess("Couldn't rename $distdir to $packagedir: $!");
+ } else {
+ my $pragmatic_dir = $self->{'CPAN_USERID'} . '000';
+ $pragmatic_dir =~ s/\W_//g;
+ $pragmatic_dir++ while -d "../$pragmatic_dir";
+ $packagedir = MM->catdir($builddir,$pragmatic_dir);
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = MM->catdir($packagedir,$f);
+ rename($f,$to) or Carp::confess("Couldn't rename $f to $to: $!");
+ }
+ }
+ $self->{'build_dir'} = $packagedir;
+ $cwd = File::Spec->updir;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
+
+ $self->debug("Changed directory to .. (self is $self [".$self->as_string."])")
+ if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ if ($CPAN::Config->{keep_source_where} =~ /^no/i ){
+ $CPAN::Frontend->myprint("Going to unlink $local_file\n");
+ unlink $local_file or Carp::carp "Couldn't unlink $local_file";
+ }
+ my($makefilepl) = MM->catfile($packagedir,"Makefile.PL");
+ unless (-f $makefilepl) {
+ my($configure) = MM->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{'configure'} = $configure;
+ } elsif (-f MM->catfile($packagedir,"Makefile")) {
+ $CPAN::Frontend->myprint(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
- $self->{writemakefile} = "YES";
- sleep 2;
- } else {
- my $fh = FileHandle->new(">$makefilepl")
- or Carp::croak("Could not open >$makefilepl");
- my $cf = $self->called_for || "unknown";
- $fh->print(
+ $self->{writemakefile} = "YES";
+ sleep 2;
+ } else {
+ my $fh = FileHandle->new(">$makefilepl")
+ or Carp::croak("Could not open >$makefilepl");
+ my $cf = $self->called_for || "unknown";
+ $fh->print(
qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
# because there was no Makefile.PL supplied.
# Autogenerated on: }.scalar localtime().qq{
WriteMakefile(NAME => q[$cf]);
});
- $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
+ $CPAN::Frontend->myprint(qq{Package comes without Makefile.PL.
Writing one on our own (calling it $cf)\n});
- }
- }
+ }
+ }
}
return $self;
}
sub unzip_me {
my($self,$local_file) = @_;
$self->{archived} = "zip";
- my $system = "$CPAN::Config->{unzip} $local_file";
- if (system($system) == 0) {
+ if ($CPAN::META->has_inst("Archive::Zip")) {
+ if (CPAN::Tarzip->unzip($local_file)) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ return;
+ }
+ my $unzip = $CPAN::Config->{unzip} or
+ $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
+ my @system = ($unzip, $local_file);
+ if (system(@system) == 0) {
$self->{unwrapped} = "YES";
} else {
$self->{unwrapped} = "NO";
my($self,$local_file) = @_;
$self->{archived} = "pm";
my $to = File::Basename::basename($local_file);
- $to =~ s/\.(gz|Z)$//;
+ $to =~ s/\.(gz|Z)(?!\n)\Z//;
if (CPAN::Tarzip->gunzip($local_file,$to)) {
$self->{unwrapped} = "YES";
} else {
my $getcwd;
$getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $pwd = CPAN->$getcwd();
- chdir($dir);
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
$CPAN::Frontend->myprint(qq{Working directory is $dir\n});
system($CPAN::Config->{'shell'}) == 0
or $CPAN::Frontend->mydie("Subprocess shell error");
- chdir($pwd);
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
+}
+
+sub cvs_import {
+ my($self) = @_;
+ $self->get;
+ my $dir = $self->dir;
+
+ my $package = $self->called_for;
+ my $module = $CPAN::META->instance('CPAN::Module', $package);
+ my $version = $module->cpan_version; # %vd
+
+ my $userid = $self->{CPAN_USERID};
+
+ my $cvs_dir = (split '/', $dir)[-1];
+ $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
+ my $cvs_root =
+ $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
+ my $cvs_site_perl =
+ $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
+ if ($cvs_site_perl) {
+ $cvs_dir = "$cvs_site_perl/$cvs_dir";
+ }
+ my $cvs_log = qq{"imported $package $version sources"};
+ $version =~ s/\./_/g;
+ my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
+ "$cvs_dir", $userid, "v$version");
+
+ my $getcwd;
+ $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
+ my $pwd = CPAN->$getcwd();
+ chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
+
+ $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
+
+ $CPAN::Frontend->myprint(qq{@cmd\n});
+ system(@cmd) == 0 or
+ $CPAN::Frontend->mydie("cvs import failed");
+ chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}
#-> sub CPAN::Distribution::readme ;
$lc_file = CPAN::FTP->localize("authors/id/@local",
"$lc_want.gz",1);
if ($lc_file) {
- $lc_file =~ s/\.gz$//;
+ $lc_file =~ s/\.gz(?!\n)\Z//;
CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file);
} else {
return;
$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,
'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;
}
}
+#-> 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])?)
- \.tar[._-]gz
- $
- }x;
- "$1.$3";
+ if ($file =~ m{ ^ perl
+ -?
+ (5)
+ ([._-])
+ (
+ \d{3}(_[0-4][0-9])?
+ |
+ \d*[24680]\.\d+
+ )
+ \.tar[._-]gz
+ (?!\n)\Z
+ }xs){
+ return "$1.$3";
+ } elsif ($self->{'CPAN_COMMENT'} && $self->{'CPAN_COMMENT'} =~ /isa_perl\(.+?\)/){
+ return $1;
+ }
}
#-> sub CPAN::Distribution::perl ;
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
$CPAN::META->instance(
'CPAN::Module',
$self->called_for
- )->cpan_version,
+ )->cpan_version, # %vd
$self->called_for,
$self->isa_perl,
$self->called_for,
$self->id);
+ sleep 5; return;
}
}
$self->get;
$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
$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{^[\#]
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){ # %vd
+ 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;
}
sub as_string {
my($self) = @_;
$self->contains;
- $self->{INST_VERSION} = $self->inst_version;
+ $self->{INST_VERSION} ||= $self->inst_version; # %vd
return $self->SUPER::as_string;
}
my $fh = FileHandle->new;
local $/ = "\n";
open($fh,$parsefile) or die "Could not open '$parsefile': $!";
- my $inpod = 0;
+ my $in_cont = 0;
$self->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
while (<$fh>) {
- $inpod = m/^=(?!head1\s+CONTENTS)/ ? 0 :
- m/^=head1\s+CONTENTS/ ? 1 : $inpod;
- next unless $inpod;
+ $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
+ m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
+ next unless $in_cont;
next if /^=/;
+ s/\#.*//;
next if /^\s+$/;
chomp;
push @result, (split " ", $_, 2)[0];
require ExtUtils::Manifest;
my $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
my $cwd = CPAN->$getcwd();
- chdir $where;
+ chdir $where or $CPAN::Frontend->mydie(qq{Could not chdir to "$where": $!});
ExtUtils::Manifest::mkmanifest();
- chdir $cwd;
+ chdir $cwd or $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd": $!});
}
my $fh = FileHandle->new($manifest)
or Carp::croak("Couldn't open $manifest: $!");
$what2 =~ s/:Bundle://;
$what2 =~ tr|:|/|;
} else {
- $what2 =~ s|Bundle/||;
+ $what2 =~ s|Bundle[/\\]||;
}
my $bu;
while (<$fh>) {
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) {
- $CPAN::Frontend->myprint(qq{\nBundle summary: }.
- qq{The following items seem to }.
- qq{have had installation problems:\n});
+ require Text::Wrap;
+ my $raw = sprintf(qq{Bundle summary:
+The following items in bundle %s had installation problems:},
+ $self->id
+ );
+ $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
+ $CPAN::Frontend->myprint("\n");
+ my $paragraph = "";
+ my %reported;
for $s ($self->contains) {
- $CPAN::Frontend->myprint( "$s " ) if $fail{$s};
+ if ($fail{$s}){
+ $paragraph .= "$s ";
+ $self->{install_failed}{$s} = undef;
+ $reported{$s} = undef;
+ }
}
- $CPAN::Frontend->myprint(qq{\n});
+ 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 {
$self->{'install'} = 'YES';
}
);
}
}
- push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
- if $self->{CPAN_VERSION};
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd
+ if $self->{CPAN_VERSION}; # %vd
push @m, sprintf($sprintf, 'CPAN_FILE', $self->{CPAN_FILE})
if $self->{CPAN_FILE};
my $sprintf3 = " %-12s %1s%1s%1s%1s (%s,%s,%s,%s)\n";
push @m, sprintf($sprintf, 'INST_FILE',
$local_file || "(not installed)");
push @m, sprintf($sprintf, 'INST_VERSION',
- $self->inst_version) if $local_file;
+ $self->inst_version) if $local_file; #%vd
join "", @m, "\n";
}
sub manpage_headline {
my($self,$local_file) = @_;
my(@local_file) = $local_file;
- $local_file =~ s/\.pm$/.pod/;
+ $local_file =~ s/\.pm(?!\n)\Z/.pod/;
push @local_file, $local_file;
my(@result,$locf);
for $locf (@local_file) {
# and do not want to
# provoke too many
# bugreports
- $self->{'CPAN_VERSION'};
+ $self->{'CPAN_VERSION'}; # %vd
}
#-> sub CPAN::Module::force ;
sub readme { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
sub look { shift->rematein('look') }
+#-> sub CPAN::Module::cvs_import ;
+sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
sub get { shift->rematein('get',@_); }
#-> sub CPAN::Module::make ;
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my($self) = @_;
- my($latest) = $self->cpan_version;
+ my($latest) = $self->cpan_version; # %vd
$latest ||= 0;
my($inst_file) = $self->inst_file;
my($have) = 0;
if (defined $inst_file) {
- $have = $self->inst_version;
+ $have = $self->inst_version; # %vd?
}
local($^W)=0;
if ($inst_file
&&
- $have >= $latest
+ $have >= $latest # %vd
) {
return 1;
}
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";
- $have =~ s/\s+//g;
- $have;
+ 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";
+ $have =~ s/^ //; # since the %vd hack these two lines here are needed
+ $have =~ s/ $//; # trailing whitespace happens all the time
+
+ # local($SIG{__WARN__}) = sub { warn "2. have[$have]"; };
+
+ if ($] >= 5.006) { # people start using v-strings
+ unless ($have =~ /^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
+ && "$2$4" ne ""
+ ||
+ /^undef$/
+ ||
+ /^-$/
+ ) {
+ $have = sprintf "%vd", $have;
+ }
+ }
+ $have =~ s/\s*//g; # stringify to float around floating point issues
+ # 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")) {
}
}
+
+# CPAN::Tarzip::gunzip
sub gunzip {
my($class,$read,$write) = @_;
if ($CPAN::META->has_inst("Compress::Zlib")) {
}
}
+
+# CPAN::Tarzip::gtest
sub gtest {
my($class,$read) = @_;
if ($CPAN::META->has_inst("Compress::Zlib")) {
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;
$ret;
}
+
+# CPAN::Tarzip::READLINE
sub READLINE {
my($self) = @_;
if (exists $self->{GZ}) {
}
}
+
+# CPAN::Tarzip::READ
sub READ {
my($self,$ref,$length,$offset) = @_;
die "read with offset not implemented" if defined $offset;
}
}
+
+# CPAN::Tarzip::DESTROY
sub DESTROY {
my($self) = @_;
if (exists $self->{GZ}) {
$gz->gzclose();
} else {
my $fh = $self->{FH};
- $fh->close;
+ $fh->close if defined $fh;
}
undef $self;
}
+
+# CPAN::Tarzip::untar
sub untar {
my($class,$file) = @_;
# had to disable, because version 0.07 seems to be buggy
if (MM->maybe_command($CPAN::Config->{'gzip'})
&&
MM->maybe_command($CPAN::Config->{'tar'})) {
- if ($^O =~ /win/i) { # irgggh
- # people find the most curious tar binaries that cannot handle
- # pipes
- my $system = "$CPAN::Config->{'gzip'} --decompress $file";
- if (system($system)==0) {
- $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
- } else {
- $CPAN::Frontend->mydie(
- qq{Couldn\'t uncompress $file\n}
- );
- }
- $file =~ s/\.gz$//;
- $system = "$CPAN::Config->{tar} xvf $file";
- if (system($system)==0) {
- $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
- } else {
- $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
- }
- return 1;
+ my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
+ "< $file | $CPAN::Config->{tar} xvf -";
+ if (system($system) != 0) {
+ # people find the most curious tar binaries that cannot handle
+ # pipes
+ my $system = "$CPAN::Config->{'gzip'} --decompress $file";
+ if (system($system)==0) {
+ $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
+ } else {
+ $CPAN::Frontend->mydie(
+ qq{Couldn\'t uncompress $file\n}
+ );
+ }
+ $file =~ s/\.gz(?!\n)\Z//;
+ $system = "$CPAN::Config->{tar} xvf $file";
+ $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
+ if (system($system)==0) {
+ $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
+ } else {
+ $CPAN::Frontend->mydie(qq{Couldn\'t untar $file\n});
+ }
+ return 1;
} else {
- my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
- "< $file | $CPAN::Config->{tar} xvf -";
- return system($system) == 0;
+ return 1;
}
} elsif ($CPAN::META->has_inst("Archive::Tar")
&&
}
}
+sub unzip {
+ my($class,$file) = @_;
+ return unless $CPAN::META->has_inst("Archive::Zip");
+ # blueprint of the code from Archive::Zip::Tree::extractTree();
+ my $zip = Archive::Zip->new();
+ my $status;
+ $status = $zip->read($file);
+ die "Read of file[$file] failed\n" if $status != Archive::Zip::AZ_OK();
+ $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
+ my @members = $zip->members();
+ for my $member ( @members ) {
+ my $f = $member->fileName();
+ my $status = $member->extractToFileNamed( $f );
+ $CPAN::META->debug("f[$f]status[$status]") if $CPAN::DEBUG;
+ die "Extracting of file[$f] from zipfile[$file] failed\n" if
+ $status != Archive::Zip::AZ_OK();
+ }
+ return 1;
+}
+
package CPAN;
1;
directory.
The CPAN module also supports the concept of named and versioned
-'bundles' of modules. Bundles simplify the handling of sets of
-related modules. See BUNDLES below.
+I<bundles> of modules. Bundles simplify the handling of sets of
+related modules. See Bundles below.
The package contains a session manager and a cache manager. There is
no status retained between sessions. The session manager keeps track
enclose it between two slashes.
The principle is that the number of found objects influences how an
-item is displayed. If the search finds one item, the result is displayed
-as object-E<gt>as_string, but if we find more than one, we display
-each as object-E<gt>as_glimpse. E.g.
-
- cpan> a ANDK
- Author id = ANDK
- EMAIL a.koenig@franz.ww.TU-Berlin.DE
- FULLNAME Andreas König
-
-
- cpan> a /andk/
- Author id = ANDK
- EMAIL a.koenig@franz.ww.TU-Berlin.DE
- FULLNAME Andreas König
-
-
- cpan> a /and.*rt/
- Author ANDYD (Andy Dougherty)
- Author MERLYN (Randal L. Schwartz)
+item is displayed. If the search finds one item, the result is
+displayed with the rather verbose method C<as_string>, but if we find
+more than one, we display each object with the terse method
+<as_glimpse>.
=item make, test, install, clean modules or distributions
-These commands take any number of arguments and investigates what is
+These commands take any number of arguments and investigate what is
necessary to perform the action. If the argument is a distribution
file name (recognized by embedded slashes), it is processed. If it is
a module, CPAN determines the distribution file in which this module
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.
being executed within the distribution file's working directory.
-=item readme, look module or distribution
+=item get, readme, look module or distribution
-These two commands take only one argument, be it a module or a
-distribution file. C<readme> unconditionally runs, displaying the
-README of the associated distribution file. C<Look> gets and
-untars (if not yet done) the distribution file, changes to the
+C<get> downloads a distribution file without further action. C<readme>
+displays the README file of the associated distribution. C<Look> gets
+and untars (if not yet done) the distribution file, changes to the
appropriate directory and opens a subshell process in that directory.
=item Signals
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
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
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;'
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.
=over 2
-=item o conf E<lt>scalar optionE<gt>
+=item C<o conf E<lt>scalar optionE<gt>>
prints the current value of the I<scalar option>
-=item o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>
+=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
Sets the value of the I<scalar option> to I<value>
-=item o conf E<lt>list optionE<gt>
+=item C<o conf E<lt>list optionE<gt>>
prints the current value of the I<list option> in MakeMaker's
neatvalue format.
-=item o conf E<lt>list optionE<gt> [shift|pop]
+=item C<o conf E<lt>list optionE<gt> [shift|pop]>
shifts or pops the array in the I<list option> variable
-=item o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>
+=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
works like the corresponding perl commands.
=head2 Note on urllist parameter's format
urllist parameters are URLs according to RFC 1738. We do a little
-guessing if your URL is not compliant, but if you have problems with file URLs, please try the correct format. Either:
+guessing if your URL is not compliant, but if you have problems with
+file URLs, please try the correct format. Either:
file://localhost/whatever/ftp/pub/CPAN/
=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.
=item ftp firewall
-This where the firewall machine runs a ftp server. This kind of firewall will
-only let you access ftp serves outside the firewall. This is usually done by
-connecting to the firewall with ftp, then entering a username like
-"user@outside.host.com"
+This where the firewall machine runs a ftp server. This kind of
+firewall will only let you access ftp servers outside the firewall.
+This is usually done by connecting to the firewall with ftp, then
+entering a username like "user@outside.host.com"
To access servers outside these type of firewalls with perl you
will need to use Net::FTP.
=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
=head1 AUTHOR
-Andreas König E<lt>a.koenig@kulturbox.deE<gt>
+Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
=head1 SEE ALSO