+# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
use vars qw{$Try_autoload
$Revision
$Frontend $Defaultsite
}; #};
-$VERSION = '1.56';
+$VERSION = '1.57_57';
-# $Id: CPAN.pm,v 1.303 2000/08/01 15:57:15 k Exp $
+# $Id: CPAN.pm,v 1.324 2000/09/01 12:04:57 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.303 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.324 $, 10)."]";
use Carp ();
use Config ();
Eval 2048
Config 4096
Tarzip 8192
+ Version 16384
];
$CPAN::DEBUG ||= 0;
$Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
CPAN::Config->load unless $CPAN::Config_loaded++;
+ CPAN::Index->read_metadata_cache;
+
my $prompt = "cpan> ";
local($^W) = 1;
unless ($Suppress_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'')";
+ "available (try 'install Bundle::CPAN')";
$CPAN::Frontend->myprint(
qq{
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> ";
use File::Find;
package CPAN::Config;
-import ExtUtils::MakeMaker 'neatvalue';
use vars qw(%can $dot_cpan);
%can = (
$pkg =~ s|::|/|g;
if (defined($name=$INC{"$pkg.pm"}))
{
- $name =~ s|^(.*)$pkg\.pm$|$1auto/$pkg/$func.al|s;
+ $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 ($@){
}
*all = \&all_objects;
-# Called by shell, not in batch mode. Not clean XXX
+# Called by shell, not in batch mode. In batch mode I see no risk in
+# having many processes updating something as installations are
+# continually checked at runtime. In shell mode I suspect it is
+# unintentional to open more than one shell at a time
+
#-> sub CPAN::checklock ;
sub checklock {
my($self) = @_;
shift->{DU};
}
+#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
my($self) = @_;
return unless -d $self->{ID};
#-> sub CPAN::Config::edit ;
# returns true on successful action
sub edit {
- my($class,@args) = @_;
+ my($self,@args) = @_;
return unless @args;
- CPAN->debug("class[$class]args[".join(" | ",@args)."]");
+ CPAN->debug("self[$self]args[".join(" | ",@args)."]");
my($o,$str,$func,$args,$key_exists);
$o = shift @args;
if($can{$o}) {
- $class->$o(@args);
+ $self->$o(@args);
return 1;
} else {
- CPAN->debug("o[$o]");
+ CPAN->debug("o[$o]") if $CPAN::DEBUG;
if ($o =~ /list$/) {
$func = shift @args;
$func ||= "";
- CPAN->debug("func[$func]");
+ CPAN->debug("func[$func]") if $CPAN::DEBUG;
my $changed;
# Let's avoid eval, it's easier to comprehend without.
if ($func eq "push") {
$CPAN::Config->{$o} = [@args];
$changed = 1;
} else {
- $CPAN::Frontend->myprint(
- join "",
- " $o ",
- ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$o}),
- "\n"
- );
+ $self->prettyprint($o);
}
if ($o eq "urllist" && $changed) {
# reset the cached values
return $changed;
} else {
$CPAN::Config->{$o} = $args[0] if defined $args[0];
- $CPAN::Frontend->myprint(" $o " .
- (defined $CPAN::Config->{$o} ?
- $CPAN::Config->{$o} : "UNDEFINED"));
+ $self->prettyprint($o);
}
}
}
+sub prettyprint {
+ my($self,$k) = @_;
+ my $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ my(@report) = ref $v eq "ARRAY" ?
+ @$v :
+ map { sprintf(" %-18s => %s\n",
+ $_,
+ defined $v->{$_} ? $v->{$_} : "UNDEFINED"
+ )} keys %$v;
+ $CPAN::Frontend->myprint(
+ join(
+ "",
+ sprintf(
+ " %-18s\n",
+ $k
+ ),
+ map {"\t$_\n"} @report
+ )
+ );
+ } elsif (defined $v) {
+ $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
+ } else {
+ $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, "UNDEFINED");
+ }
+}
+
#-> sub CPAN::Config::commit ;
sub commit {
my($self,$configpm) = @_;
# system wide settings
shift @INC;
}
- return unless @miss = $self->not_loaded;
- # XXX better check for arrayrefs too
+ return unless @miss = $self->missing_config_data;
+
require CPAN::FirstTime;
my($configpm,$fh,$redo,$theycalled);
$redo ||= "";
CPAN::FirstTime::init($configpm);
}
-#-> sub CPAN::Config::not_loaded ;
-sub not_loaded {
+#-> sub CPAN::Config::missing_config_data ;
+sub missing_config_data {
my(@miss);
- for (qw(
- cpan_home keep_source_where build_dir build_cache scan_cache
- index_expire gzip tar unzip make pager makepl_arg make_arg
- make_install_arg urllist inhibit_startup_message
- ftp_proxy http_proxy no_proxy prerequisites_policy
- )) {
+ for (
+ "cpan_home", "keep_source_where", "build_dir", "build_cache",
+ "scan_cache", "index_expire", "gzip", "tar", "unzip", "make", "pager",
+ "makepl_arg", "make_arg", "make_install_arg", "urllist",
+ "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
+ "prerequisites_policy",
+
+ # "cache_metadata" # not yet stable enough
+
+ ) {
push @miss, $_ unless defined $CPAN::Config->{$_};
}
return @miss;
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");
}
}
}
#-> sub CPAN::Shell::o ;
+
+# CPAN::Shell::o and CPAN::Config::edit are closely related. I suspect
+# some code duplication
sub o {
my($self,$o_type,@o_what) = @_;
$o_type ||= "";
CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
if ($o_type eq 'conf') {
shift @o_what if @o_what && $o_what[0] eq 'help';
- if (!@o_what) {
+ if (!@o_what) { # print all things, "o conf"
my($k,$v);
$CPAN::Frontend->myprint("CPAN::Config options");
if (exists $INC{'CPAN/Config.pm'}) {
}
$CPAN::Frontend->myprint("\n");
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(
- "",
- sprintf(
- " %-18s\n",
- $k
- ),
- map {"\t$_\n"} @report
- )
- );
- } else {
- $CPAN::Frontend->myprint(sprintf " %-18s %s\n", $k, $v);
- }
+ CPAN::Config->prettyprint($k);
}
$CPAN::Frontend->myprint("\n");
} elsif (!CPAN::Config->edit(@o_what)) {
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{ 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 /x;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
+ next if $dist->isa_perl;
next unless $module->xs_file;
local($|) = 1;
$CPAN::Frontend->myprint(".");
my($self) = shift @_;
my($what) = shift @_;
CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
- Carp::croak "Usage: \$obj->_u_r_common($what)" unless defined $what;
- Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless $what =~ /^[aru]$/;
+ Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
+ $what && $what =~ /^[aru]$/;
my(@args) = @_;
@args = '/./' unless @args;
my(@result,$module,%seen,%need,$headerdone,
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 not needed
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 already applied
} elsif ($what eq "r") {
- $have = $module->inst_version;
+ $have = $module->inst_version; # %vd already applied
local($^W) = 0;
if ($have eq "undef"){
$version_undefs++;
} elsif ($have == 0){
$version_zeroes++;
}
- next if $have >= $latest;
+ next unless CPAN::Version->vgt($latest, $have);
# to be pedantic we should probably say:
# && !($have eq "undef" && $latest ne "undef" && $latest gt "");
# to catch the case where CPAN has a version 0 and we have a version undef
"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);
+ $CPAN::Frontend->myprint(sprintf $sprintf,
+ $module->id,
+ $have,
+ $latest,
+ $file);
$need{$module->id}++;
}
unless (%need) {
my $obj;
if (ref $s) {
$obj = $s;
+ } elsif ($s =~ m|^/|) { # looks like a regexp
+ $CPAN::Frontend->mydie("Sorry, $meth with a regular expression is not supported");
} elsif ($s =~ m|/|) { # looks like a file
$obj = $CPAN::META->instance('CPAN::Distribution',$s);
} elsif ($s =~ m|^Bundle::|) {
if $CPAN::META->exists('CPAN::Module',$s);
}
if (ref $obj) {
+ if ($pragma
+ &&
+ ($] < 5.00303 || $obj->can($pragma))){
+ ### compatibility with 5.003
+ $obj->$pragma($meth); # the pragma "force" in
+ # "CPAN::Distribution" must know
+ # what we are intending
+ }
+ if ($]>=5.00303 && $obj->can('called_for')) {
+ $obj->called_for($s);
+ }
CPAN->debug(
qq{pragma[$pragma]meth[$meth]obj[$obj]as_string\[}.
$obj->as_string.
qq{\]}
) if $CPAN::DEBUG;
- $obj->$pragma()
- if
- $pragma
- &&
- ($] < 5.00303 || $obj->can($pragma)); ###
- ### compatibility
- ### with
- ### 5.003
- if ($]>=5.00303 && $obj->can('called_for')) {
- $obj->called_for($s);
- }
CPAN::Queue->delete($s) if $obj->$meth(); # if it is more
# than once in
# the queue
}
#-> sub CPAN::FTP::localize ;
-# sorry for the ugly code here, I'll clean it up as soon as Net::FTP
-# is in the core
sub localize {
my($self,$file,$aslocal,$force) = @_;
$force ||= 0;
$Ua = LWP::UserAgent->new;
my($var);
$Ua->proxy('ftp', $var)
- if $var = $CPAN::Config->{'ftp_proxy'} || $ENV{'ftp_proxy'};
+ if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
$Ua->proxy('http', $var)
- if $var = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
+ if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
$Ua->no_proxy($var)
- if $var = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
+ if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
}
}
+ $ENV{ftp_proxy} = $CPAN::Config->{ftp_proxy} if $CPAN::Config->{ftp_proxy};
+ $ENV{http_proxy} = $CPAN::Config->{http_proxy} if $CPAN::Config->{http_proxy};
+ $ENV{no_proxy} = $CPAN::Config->{no_proxy} if $CPAN::Config->{no_proxy};
# Try the list of urls for each single object. We keep a record
# where we did get a file from
($a == $Thesite)
} 0..$last;
}
- my($level,@levels);
+ my(@levels);
if ($Themethod) {
@levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
} else {
@levels = qw/easy hard hardest/;
}
@levels = qw/easy/ if $^O eq 'MacOS';
- for $level (@levels) {
+ my($levelno);
+ for $levelno (0..$#levels) {
+ my $level = $levels[$levelno];
my $method = "host$level";
my @host_seq = $level eq "easy" ?
@reordered : 0..$last; # reordered has CDROM up front
return $ret;
} else {
unlink $aslocal;
+ last if $CPAN::Signal; # need to cleanup
}
}
- my(@mess);
- push @mess,
- qq{Please check, if the URLs I found in your configuration file \(}.
- join(", ", @{$CPAN::Config->{urllist}}).
- qq{\) are valid. The urllist can be edited.},
- qq{E.g. with ``o conf urllist push ftp://myurl/''};
- $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
- sleep 2;
- $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
+ unless ($CPAN::Signal) {
+ my(@mess);
+ push @mess,
+ qq{Please check, if the URLs I found in your configuration file \(}.
+ join(", ", @{$CPAN::Config->{urllist}}).
+ qq{\) are valid. The urllist can be edited.},
+ qq{E.g. with 'o conf urllist push ftp://myurl/'};
+ $CPAN::Frontend->myprint(Text::Wrap::wrap("","",@mess). "\n\n");
+ sleep 2;
+ $CPAN::Frontend->myprint("Cannot fetch $file\n\n");
+ }
if ($restore) {
rename "$aslocal.bak", $aslocal;
$CPAN::Frontend->myprint("Trying to get away with old file:\n" .
my($self,$host_seq,$file,$aslocal) = @_;
my($i);
HOSTEASY: for $i (@$host_seq) {
- my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
+ my $url = $CPAN::Config->{urllist}[$i] || $CPAN::Defaultsite;
unless ($self->is_reachable($url)) {
$CPAN::Frontend->myprint("Skipping $url (seems to be not reachable)\n");
sleep 2;
}
}
}
- if ($CPAN::META->has_usable('LWP')) {
+ if ($CPAN::META->has_usable('LWP')) {
$CPAN::Frontend->myprint("Fetching with LWP:
$url
");
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
) {
$Thesite = $i;
return $aslocal;
- } else {
- # next HOSTEASY ;
}
} else {
- # Alan Burlison informed me that in firewall envs Net::FTP
- # can still succeed where LWP fails. So we do not skip
- # Net::FTP anymore when LWP is available.
- # next HOSTEASY ;
+ # Alan Burlison informed me that in firewall environments
+ # Net::FTP can still succeed where LWP fails. So we do not
+ # skip Net::FTP anymore when LWP is available.
}
} else {
$self->debug("LWP not installed") if $CPAN::DEBUG;
}
+ return if $CPAN::Signal;
if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
# that's the nice and easy way thanks to Graham
my($host,$dir,$getfile) = ($1,$2,$3);
$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
# next HOSTEASY;
}
}
+ return if $CPAN::Signal;
}
}
}
$Thesite = $i;
return $aslocal;
- } elsif ($url !~ /\.gz$/) {
+ } elsif ($url !~ /\.gz(?!\n)\Z/) {
unlink $asl_ungz if
-f $asl_ungz && -s _ == 0;
my $gz = "$aslocal.gz";
returned status $estatus (wstat $wstatus)$size
});
}
- }
- }
+ return if $CPAN::Signal;
+ } # lynx,ncftpget,ncftp
+ } # host
}
sub hosthardest {
} else {
$CPAN::Frontend->myprint("Hmm... Still failed!\n");
}
+ return if $CPAN::Signal;
} else {
$CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
qq{correctly protected.\n});
} else {
$CPAN::Frontend->myprint("Bad luck... Still failed!\n");
}
+ return if $CPAN::Signal;
$CPAN::Frontend->myprint("Can't access URL $url.\n\n");
sleep 2;
- }
+ } # host
}
sub talk_ftp {
File::Spec->catfile('modules', '03mlist.gz') :
File::Spec->catfile('modules', '03modlist.data.gz'),
$force));
+ $cl->write_metadata_cache;
$t2 = time;
$debug .= "03[".($t2 - $time)."]";
$time = $t2;
#-> 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");
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
+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) {
$index_target, $line_count, scalar(@lines);
}
+ # A necessity since we have metadata_cache: delete what isn't
+ # there anymore
+ my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
+ CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
+ my(%exists);
foreach (@lines) {
chomp;
- my($mod,$version,$dist) = split;
-### $version =~ s/^\+//;
-
- # if it is a bundle, instantiate a bundle object
+ # 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;
my($bundle,$id,$userid);
if ($mod eq 'CPAN' &&
CPAN::Queue->exists('CPAN')
)
) {
- local($^W)= 0;
- if ($version > $CPAN::VERSION){
- $CPAN::Frontend->myprint(qq{
- There\'s a new CPAN.pm version (v$version) available!
+ local($^W)= 0;
+ 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
without quitting the current session. It should be a seamless upgrade
while we are running...
-});
- sleep 2;
+}); #});
+ sleep 2;
$CPAN::Frontend->myprint(qq{\n});
}
last if $CPAN::Signal;
if ($bundle){
$id = $CPAN::META->instance('CPAN::Bundle',$mod);
- # warn "made mod[$mod]a bundle";
# Let's make it a module too, because bundles have so much
# in common with modules
$CPAN::META->instance('CPAN::Module',$mod);
- # warn "made mod[$mod]a module";
-# This "next" makes us faster but if the job is running long, we ignore
-# rereads which is bad. So we have to be a bit slower again.
-# } elsif ($CPAN::META->exists('CPAN::Module',$mod)) {
-# next;
+ } else {
- }
- else {
# instantiate a module object
$id = $CPAN::META->instance('CPAN::Module',$mod);
+
}
- if ($id->cpan_file ne $dist){
- $userid = $cl->userid($dist);
+ if ($id->cpan_file ne $dist){ # update only if file is
+ # different. CPAN prohibits same
+ # name with different version
+ $userid = $self->userid($dist);
$id->set(
'CPAN_USERID' => $userid,
- 'CPAN_VERSION' => $version,
- 'CPAN_FILE' => $dist
+ 'CPAN_VERSION' => $version, # %vd not needed
+ 'CPAN_FILE' => $dist,
+ 'CPAN_COMMENT' => $comment,
);
}
'CPAN_USERID' => $userid
);
}
-
+ if ($secondtime) {
+ for my $name ($mod,$dist) {
+ # CPAN->debug("confirm existence of name[$name]") if $CPAN::DEBUG;
+ $exists{$name} = undef;
+ }
+ }
return if $CPAN::Signal;
}
undef $fh;
+ if ($secondtime) {
+ for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
+ for my $o ($CPAN::META->all_objects($class)) {
+ next if exists $exists{$o->{ID}};
+ $CPAN::META->delete($class,$o->{ID});
+ CPAN->debug("deleting ID[$o->{ID}] in class[$class]") if $CPAN::DEBUG;
+ }
+ }
+ }
}
#-> sub CPAN::Index::rd_modlist ;
}
}
+#-> sub CPAN::Index::write_metadata_cache ;
+sub write_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return unless $CPAN::META->has_usable("Storable");
+ my $cache;
+ foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
+ CPAN::Distribution)) {
+ $cache->{$k} = $CPAN::META->{$k};
+ }
+ my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
+ $CPAN::Frontend->myprint("Going to write $metadata_file\n");
+ $cache->{last_time} = $last_time;
+ eval { Storable::nstore($cache, $metadata_file) };
+ $CPAN::Frontent->mywarn($@) if $@;
+}
+
+#-> sub CPAN::Index::read_metadata_cache ;
+sub read_metadata_cache {
+ my($self) = @_;
+ return unless $CPAN::Config->{'cache_metadata'};
+ return unless $CPAN::META->has_usable("Storable");
+ my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata");
+ return unless -r $metadata_file and -f $metadata_file;
+ $CPAN::Frontend->myprint("Going to read $metadata_file\n");
+ my $cache;
+ eval { $cache = Storable::retrieve($metadata_file) };
+ $CPAN::Frontend->mywarn($@) if $@;
+ return if (!$cache || ref $cache ne 'HASH');
+ while(my($k,$v) = each %$cache) {
+ next unless $k =~ /^CPAN::/;
+ for my $k2 (keys %$v) {
+ delete $v->{$k2}{force_update}; # if a buggy CPAN.pm left
+ # over such a mess, it's
+ # high time to correct now
+ }
+ $CPAN::META->{$k} = $v;
+ }
+ $last_time = $cache->{last_time};
+}
+
package CPAN::InfoObj;
#-> sub CPAN::InfoObj::new ;
join "", @m;
}
-# Dead code, I would have liked to have,,, but it was never reached,,,
-#sub make {
-# my($self) = @_;
-# return "Don't be silly, you can't make $self->{FULLNAME} ;-)\n";
-#}
-
#-> sub CPAN::Author::fullname ;
sub fullname { shift->{'FULLNAME'} }
*name = \&fullname;
EXCUSE: {
my @e;
exists $self->{'build_dir'} and push @e,
- "Unwrapped into directory $self->{'build_dir'}";
+ "Is already unwrapped into directory $self->{'build_dir'}";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
my($local_file);
$local_file =
CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
+ return if $CPAN::Signal;
$self->{localfile} = $local_file;
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
my $builddir = $CPAN::META->{cachemgr}->dir;
$self->debug("doing chdir $builddir") if $CPAN::DEBUG;
chdir $builddir or Carp::croak("Couldn't chdir $builddir: $!");
$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;
+ return if $CPAN::Signal;
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 $_ !~ /^\.\.?$/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;
- 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) = @_;
- 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 = ($unzip, $local_file);
- if (system(@system) == 0) {
+ if (CPAN::Tarzip->unzip($local_file)) {
$self->{unwrapped} = "YES";
} else {
$self->{unwrapped} = "NO";
}
+ return;
}
sub pm2dir_me {
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 {
sub new {
my($class,%att) = @_;
- $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+ # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
my $this = { %att };
return bless $this, $class;
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 $package = $self->called_for;
my $module = $CPAN::META->instance('CPAN::Module', $package);
- my $version = $module->cpan_version;
+ my $version = $module->cpan_version; # %vd not needed
my $userid = $self->{CPAN_USERID};
my $cvs_dir = (split '/', $dir)[-1];
- $cvs_dir =~ s/-\d+[^-]+$//;
+ $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
my $cvs_root =
$CPAN::Config->{cvsroot} || $ENV{CVSROOT};
my $cvs_site_perl =
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});
$CPAN::Frontend->myprint(qq{@cmd\n});
system(@cmd) == 0 or
$CPAN::Frontend->mydie("cvs import failed");
- chdir($pwd);
+ 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;
)->as_string);
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
+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;
- return;
+ $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
+
+ # former versions just returned here but this seems a
+ # serious threat that deserves a die
+
+ # $CPAN::Frontend->myprint("\n\n");
+ # sleep 3;
+ # return;
}
# close $fh if fileno($fh);
} else {
}
#-> sub CPAN::Distribution::force ;
+
+# Both modules and distributions know if "force" is in effect by
+# autoinspection, not by inspecting a global variable. One of the
+# reason why this was chosen to work that way was the treatment of
+# dependencies. They should not autpomatically inherit the force
+# status. But this has the downside that ^C and die() will return to
+# the prompt but will not be able to reset the force_update
+# attributes. We try to correct for it currently in the read_metadata
+# routine, and immediately before we check for a Signal. I hope this
+# works out in one of v1.57_53ff
+
sub force {
- my($self) = @_;
- $self->{'force_update'}++;
+ my($self, $method) = @_;
for my $att (qw(
MD5_STATUS archived build_dir localfile make install unwrapped
writemakefile
)) {
delete $self->{$att};
}
+ if ($method && $method eq "install") {
+ $self->{"force_update"}++; # name should probably have been force_install
+ }
+}
+
+#-> sub CPAN::Distribution::unforce ;
+sub unforce {
+ my($self) = @_;
+ delete $self->{'force_update'};
}
#-> 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*[24680]\.\d+
- )
- \.tar[._-]gz
- $
- }xs;
- "$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 ;
# Emergency brake if they said install Pippi and get newest perl
if ($self->isa_perl) {
if (
- $self->called_for ne $self->id && ! $self->{'force_update'}
+ $self->called_for ne $self->id &&
+ ! $self->{force_update}
) {
# if we die here, we break bundles
$CPAN::Frontend->mywarn(sprintf qq{
$CPAN::META->instance(
'CPAN::Module',
$self->called_for
- )->cpan_version,
+ )->cpan_version, # %vd not needed
$self->called_for,
$self->isa_perl,
$self->called_for,
}
if (-f "Makefile") {
$self->{writemakefile} = "YES";
+ delete $self->{make_clean}; # if cleaned before, enable next
} else {
$self->{writemakefile} =
qq{NO Makefile.PL refused to write a Makefile.};
# $self->{writemakefile} .= <$fh>;
}
}
- return if $CPAN::Signal;
+ if ($CPAN::Signal){
+ delete $self->{force_update};
+ return;
+ }
if (my @prereq = $self->needs_prereq){
my $id = $self->id;
$CPAN::Frontend->myprint("---- Dependencies detected ".
# check, because if 'force' is in effect, nobody else will check.
{
local($^W) = 0;
- if (defined $mo->inst_file &&
- $mo->inst_version >= $need_version){
+ if (
+ defined $mo->inst_file &&
+ ! CPAN::Version->vgt($need_version, $mo->inst_version)
+ ){
CPAN->debug(sprintf "inst_file[%s]inst_version[%s]need_version[%s]",
- $mo->inst_file, $mo->inst_version, $need_version
+ $mo->inst_file,
+ $mo->inst_version,
+ CPAN::Version->readable($need_version)
);
next NEED;
}
sub test {
my($self) = @_;
$self->make;
- return if $CPAN::Signal;
+ if ($CPAN::Signal){
+ delete $self->{force_update};
+ return;
+ }
$CPAN::Frontend->myprint("Running make test\n");
EXCUSE: {
my @e;
exists $self->{'make'} and
$self->{'make'} eq 'NO' and
- push @e, "Oops, make had returned bad status";
+ push @e, "Can't test without successful make";
exists $self->{'build_dir'} or push @e, "Has no own directory";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
$CPAN::Frontend->myprint("Running make clean\n");
EXCUSE: {
my @e;
- exists $self->{'build_dir'} or push @e, "Has no own directory";
+ exists $self->{make_clean} and $self->{make_clean} eq "YES" and
+ push @e, "make clean already called once";
+ exists $self->{build_dir} or push @e, "Has no own directory";
$CPAN::Frontend->myprint(join "", map {" $_\n"} @e) and return if @e;
}
chdir $self->{'build_dir'} or
my $system = join " ", $CPAN::Config->{'make'}, "clean";
if (system($system) == 0) {
- $CPAN::Frontend->myprint(" $system -- OK\n");
- $self->force;
+ $CPAN::Frontend->myprint(" $system -- OK\n");
+
+ # $self->force;
+
+ # Jost Krieger pointed out that this "force" was wrong because
+ # it has the effect that the next "install" on this distribution
+ # will untar everything again. Instead we should bring the
+ # object's state back to where it is after untarring.
+
+ delete $self->{force_update};
+ delete $self->{install};
+ delete $self->{writemakefile};
+ delete $self->{make};
+ delete $self->{make_test}; # no matter if yes or no, tests must be redone
+ $self->{make_clean} = "YES";
+
} else {
- # Hmmm, what to do if make clean failed?
+ # Hmmm, what to do if make clean failed?
+
+ $CPAN::Frontend->myprint(qq{ $system -- NOT OK
+
+make clean did not succeed, marking directory as unusable for further work.
+});
+ $self->force("make"); # so that this directory won't be used again
+
}
}
sub install {
my($self) = @_;
$self->test;
- return if $CPAN::Signal;
+ if ($CPAN::Signal){
+ delete $self->{force_update};
+ return;
+ }
$CPAN::Frontend->myprint("Running make install\n");
EXCUSE: {
my @e;
exists $self->{'make'} and
$self->{'make'} eq 'NO' and
- push @e, "Oops, make had returned bad status";
+ push @e, "make had returned bad status, won't install without force";
push @e, "make test had returned bad status, ".
"won't install without force"
qq{to root to install the package\n});
}
}
+ delete $self->{force_update};
}
#-> sub CPAN::Distribution::dir ;
sub as_string {
my($self) = @_;
$self->contains;
- $self->{INST_VERSION} = $self->inst_version;
+ # following line must be "=", not "||=" because we have a moving target
+ $self->{INST_VERSION} = $self->inst_version; # %vd already applied
return $self->SUPER::as_string;
}
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: $!");
);
}
}
- push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION})
- if $self->{CPAN_VERSION};
+ push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd not needed
+ if $self->{CPAN_VERSION}; # %vd not needed
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 already applied
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) {
my $email = $CPAN::META->instance(CPAN::Author,
$self->{'userid'})->email;
unless (defined $fullname && defined $email) {
- return "Contact Author $self->{userid} (Try ``a $self->{userid}'')";
+ return "Contact Author $self->{userid} (Try 'a $self->{userid}')";
}
return "Contact Author $fullname <$email>";
} else {
# and do not want to
# provoke too many
# bugreports
- $self->{'CPAN_VERSION'};
+ $self->{'CPAN_VERSION'}; # %vd not needed
}
#-> sub CPAN::Module::force ;
Either the module has not yet been uploaded to CPAN, or it is
temporary unavailable. Please contact the author to find out
- more about the status. Try ``i %s''.
+ more about the status. Try 'i %s'.
},
$self->id,
$self->id,
}
my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
$pack->called_for($self->id);
- $pack->force if exists $self->{'force_update'};
+ $pack->force($meth) if exists $self->{'force_update'};
$pack->$meth();
+ $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
delete $self->{'force_update'};
}
#-> sub CPAN::Module::uptodate ;
sub uptodate {
my($self) = @_;
- my($latest) = $self->cpan_version;
+ my($latest) = $self->cpan_version; # %vd not needed
$latest ||= 0;
my($inst_file) = $self->inst_file;
my($have) = 0;
if (defined $inst_file) {
- $have = $self->inst_version;
+ $have = $self->inst_version; # %vd already applied
}
local($^W)=0;
if ($inst_file
&&
- $have >= $latest
+ ! CPAN::Version->vgt($latest, $have)
) {
return 1;
}
my($self) = @_;
my $parsefile = $self->inst_file or return;
local($^W) = 0 if $] < 5.00303 && $ExtUtils::MakeMaker::VERSION < 5.38;
- # warn "HERE";
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.
+ # the following 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]"; };
+
+ # My thoughts about why %vd processing should happen here
+
+ # Alt1 maintain it as string with leading v:
+ # read index files do nothing
+ # compare it use utility for compare
+ # print it do nothing
+
+ # Alt2 maintain it as what is is
+ # read index files convert
+ # compare it use utility because there's still a ">" vs "gt" issue
+ # print it use CPAN::Version for print
+
+ # Seems cleaner to hold it in memory as a string starting with a "v"
+
+ # If the author of this module made a mistake and wrote a quoted
+ # "v1.13" instead of v1.13, we simply leave it at that with the
+ # effect that *we* will treat it like a v-tring while the rest of
+ # perl won't. Seems sensible when we consider that any action we
+ # could take now would just add complexity.
+
+ $have = CPAN::Version->readable($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
}
# 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'})
+ if (0) { # makes changing order easier
+ } elsif ($CPAN::META->has_inst("Archive::Tar")
+ &&
+ $CPAN::META->has_inst("Compress::Zlib") ) {
+ my $tar = Archive::Tar->new($file,1);
+ my $af; # archive file
+ for $af ($tar->list_files) {
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains illegal member [$af]");
+ }
+ $CPAN::Frontend->myprint("$af\n");
+ $tar->extract($af);
+ return if $CPAN::Signal;
+ }
+
+ ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
+ if ($^O eq 'MacOS');
+
+ return 1;
+ } elsif (MM->maybe_command($CPAN::Config->{'gzip'})
&&
MM->maybe_command($CPAN::Config->{'tar'})) {
my $system = "$CPAN::Config->{'gzip'} --decompress --stdout " .
qq{Couldn\'t uncompress $file\n}
);
}
- $file =~ s/\.gz$//;
+ $file =~ s/\.gz(?!\n)\Z//;
$system = "$CPAN::Config->{tar} xvf $file";
$CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
if (system($system)==0) {
} else {
return 1;
}
- } elsif ($CPAN::META->has_inst("Archive::Tar")
- &&
- $CPAN::META->has_inst("Compress::Zlib") ) {
- my $tar = Archive::Tar->new($file,1);
- $tar->extract($tar->list_files); # I'm pretty sure we have nothing
- # that isn't compressed
-
- ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1)
- if ($^O eq 'MacOS');
-
- return 1;
} else {
$CPAN::Frontend->mydie(qq{
CPAN.pm needs either both external programs tar and gzip installed or
}
}
+sub unzip {
+ my($class,$file) = @_;
+ if ($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 $af = $member->fileName();
+ if ($af =~ m!^(/|\.\./)!) {
+ $CPAN::Frontend->mydie("ALERT: Archive contains illegal member [$af]");
+ }
+ my $status = $member->extractToFileNamed( $af );
+ $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
+ die "Extracting of file[$af] from zipfile[$file] failed\n" if
+ $status != Archive::Zip::AZ_OK();
+ return if $CPAN::Signal;
+ }
+ return 1;
+ } else {
+ my $unzip = $CPAN::Config->{unzip} or
+ $CPAN::Frontend->mydie("Cannot unzip, no unzip program available");
+ my @system = ($unzip, $file);
+ return system(@system) == 0;
+ }
+}
+
+
+package CPAN::Version;
+# CPAN::Version::vcmp courtesy Jost Krieger
+sub vcmp {
+ my($self,$l,$r) = @_;
+ local($^W) = 0;
+ CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+
+ return 0 if $l eq $r; # short circuit for quicker success
+
+ if ($l=~/^v/ <=> $r=~/^v/) {
+ for ($l,$r) {
+ next if /^v/;
+ $_ = $self->float2vv($_);
+ }
+ }
+
+ return
+ ($l ne "undef") <=> ($r ne "undef") ||
+ ($] >= 5.006 &&
+ $l =~ /^v/ &&
+ $r =~ /^v/ &&
+ $self->vstring($l) cmp $self->vstring($r)) ||
+ $l <=> $r ||
+ $l cmp $r;
+}
+
+sub vgt {
+ my($self,$l,$r) = @_;
+ $self->vcmp($l,$r) > 0;
+}
+
+sub vstring {
+ my($self,$n) = @_;
+ $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid argument [$n]";
+ pack "U*", split /\./, $n;
+}
+
+# vv => visible vstring
+sub float2vv {
+ my($self,$n) = @_;
+ my($rev) = int($n);
+ $rev ||= 0;
+ my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits so that
+ # architecture cannot
+ # influnce
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret;
+}
+
+sub readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
+
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
+
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
+
+ # And if they say v1.2, then the old perl takes it as "v12"
+
+ $CPAN::Frontend->mywarn("Suspicious version string seen [$n]");
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
+ return $better;
+}
+
package CPAN;
1;
build_cache size of cache for directories to build modules
build_dir locally accessible directory to build modules
index_expire after this many days refetch index files
+ cache_metadata use serializer to cache metadata
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
=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/
=item SOCKS
If you are using a SOCKS firewall you will need to compile perl and link
-it with the SOCKS library, this is what is normally called a ``socksified''
+it with the SOCKS library, this is what is normally called a 'socksified'
perl. With this executable you will be able to connect to servers outside
the firewall as if it is not there.
=back
-=head2 Configuring lynx or ncftp for going throught the firewall
+=head2 Configuring lynx or ncftp for going through a firewall
If you can go through your firewall with e.g. lynx, presumably with a
command such as
so that STDOUT is captured in a file for later inspection.
+
+=item I am not root, how can I install a module in a personal directory?
+
+You will most probably like something like this:
+
+ o conf makepl_arg "LIB=~/myperl/lib \
+ INSTALLMAN1DIR=~/myperl/man/man1 \
+ INSTALLMAN3DIR=~/myperl/man/man3"
+ install Sybase::Sybperl
+
+You can make this setting permanent like all C<o conf> settings with
+C<o conf commit>.
+
+You will have to add ~/myperl/man to the MANPATH environment variable
+and also tell your perl programs to look into ~/myperl/lib, e.g. by
+including
+
+ use lib "$ENV{HOME}/myperl/lib";
+
+or setting the PERL5LIB environment variable.
+
+Another thing you should bear in mind is that the UNINST parameter
+should never be set if you are not root.
+
+=item How to get a package, unwrap it, and make a change before building it?
+
+ look Sybase::Sybperl
+
+=item I installed a Bundle and had a couple of fails. When I retried,
+ everything resolved nicely. Can this be fixed to work on first
+ try?
+
+The reason for this is that CPAN does not know the dependencies of all
+modules when it starts out. To decide about the additional items to
+install, it just uses data found in the generated Makefile. An
+undetected missing piece breaks the process. But it may well be that
+your Bundle installs some prerequisite later than some depending item
+and thus your second try is able to resolve everything. Please note,
+CPAN.pm does not know the dependency tree in advance and cannot sort
+the queue of things to install in a topologically correct sequence.
+For bundles which you need to install often, it is recommended to do
+the sorting manually. It is planned to improve the metadata situation
+for dependencies on CPAN in general, but this will still take some
+time.
+
=back
=head1 BUGS
We should give coverage for B<all> of the CPAN and not just the PAUSE
part, right? In this discussion CPAN and PAUSE have become equal --
-but they are not. PAUSE is authors/ and modules/. CPAN is PAUSE plus
-the clpa/, doc/, misc/, ports/, src/, scripts/.
+but they are not. PAUSE is authors/, modules/ and scripts/. CPAN is
+PAUSE plus the clpa/, doc/, misc/, ports/, and src/.
Future development should be directed towards a better integration of
the other parts.
projects / p5sagit/p5-mst-13.2.git / blobdiff