From: Jarkko Hietaniemi Date: Fri, 9 Feb 2001 22:41:35 +0000 (+0000) Subject: Upgrade to CPAN 1.59_54, from Andreas König. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c049f95368b5429d658957f04652ad3e5f2d09a0;p=p5sagit%2Fp5-mst-13.2.git Upgrade to CPAN 1.59_54, from Andreas König. p4raw-id: //depot/perl@8755 --- diff --git a/lib/CPAN.pm b/lib/CPAN.pm index ed48d68..fdaadb3 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -1,11 +1,11 @@ # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- package CPAN; -$VERSION = '1.59_51'; -# $Id: CPAN.pm,v 1.381 2000/12/01 08:13:05 k Exp $ +$VERSION = '1.59_54'; +# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $ # only used during development: $Revision = ""; -# $Revision = "[".substr(q$Revision: 1.381 $, 10)."]"; +# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]"; use Carp (); use Config (); @@ -229,6 +229,10 @@ package CPAN::FTP; use vars qw($Ua $Thesite $Themethod); @CPAN::FTP::ISA = qw(CPAN::Debug); +package CPAN::LWP::UserAgent; +use vars qw(@ISA $USER $PASSWD $SETUPDONE); +# we delay requiring LWP::UserAgent and setting up inheritence until we need it + package CPAN::Complete; @CPAN::Complete::ISA = qw(CPAN::Debug); @CPAN::Complete::COMMANDS = sort qw( @@ -238,10 +242,10 @@ package CPAN::Complete; ) unless @CPAN::Complete::COMMANDS; package CPAN::Index; -use vars qw($last_time $date_of_03); +use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03); @CPAN::Index::ISA = qw(CPAN::Debug); -$last_time ||= 0; -$date_of_03 ||= 0; +$LAST_TIME ||= 0; +$DATE_OF_03 ||= 0; # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57 sub PROTOCOL { 2.0 } @@ -1249,19 +1253,17 @@ sub h { } else { $CPAN::Frontend->myprint(q{ 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 + command argument description + a,b,d,m WORD or /REGEXP/ about authors, bundles, distributions, modules + i WORD or /REGEXP/ about anything of above + r NONE reinstall recommendations + ls AUTHOR about files in the author's directory Download, Test, Make, Install... get download make make (implies get) - test modules, make test (implies make) - install dists, bundles make install (implies test) + 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 @@ -1281,7 +1283,7 @@ sub a { my($self,@arg) = @_; # authors are always UPPERCASE for (@arg) { - $_ = uc $_; + $_ = uc $_ unless /=/; } $CPAN::Frontend->myprint($self->format_result('Author',@arg)); } @@ -1289,10 +1291,15 @@ sub a { #-> sub CPAN::Shell::ls ; sub ls { my($self,@arg) = @_; + my @accept; for (@arg) { - $_ = uc $_; + unless (/^[A-Z\-]+$/i) { + $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author"); + next; + } + push @accept, uc $_; } - for my $a (@arg){ + for my $a (@accept){ my $author = $self->expand('Author',$a) or die "No author found for $a"; $author->ls; } @@ -1310,7 +1317,7 @@ sub local_bundles { if ($dh = DirHandle->new($bdir)) { # may fail my($entry); for $entry ($dh->read) { - next if $entry =~ /^\./; # + next if $entry =~ /^\./; if (-d MM->catdir($bdir,$entry)){ push @bbase, "$bbase\::$entry"; } else { @@ -1963,7 +1970,7 @@ sub rematein { } if (ref $obj) { $obj->color_cmd_tmps(0,1); - CPAN::Queue->new($s); + CPAN::Queue->new($obj->id); push @qcopy, $obj; } elsif ($CPAN::META->exists('CPAN::Author',$s)) { $obj = $CPAN::META->instance('CPAN::Author',$s); @@ -2054,6 +2061,60 @@ sub look { shift->rematein('look',@_); } #-> sub CPAN::Shell::cvs_import ; sub cvs_import { shift->rematein('cvs_import',@_); } +package CPAN::LWP::UserAgent; + +sub config { + return if $SETUPDONE; + if ($CPAN::META->has_usable('LWP::UserAgent')) { + require LWP::UserAgent; + @ISA = qw(Exporter LWP::UserAgent); + $SETUPDONE++; + } else { + $CPAN::Frontent->mywarn("LWP::UserAgent not available\n"); + } +} + +sub get_basic_credentials { + my($self, $realm, $uri, $proxy) = @_; + return unless $proxy; + if ($USER && $PASSWD) { + } elsif (defined $CPAN::Config->{proxy_user} && + defined $CPAN::Config->{proxy_pass}) { + $USER = $CPAN::Config->{proxy_user}; + $PASSWD = $CPAN::Config->{proxy_pass}; + } else { + require ExtUtils::MakeMaker; + ExtUtils::MakeMaker->import(qw(prompt)); + $USER = prompt("Proxy authentication needed! + (Note: to permanently configure username and password run + o conf proxy_user your_username + o conf proxy_pass your_password + )\nUsername:"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("noecho"); + } else { + $CPAN::Frontend->mywarn("Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"); + } + $PASSWD = prompt("Password:"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("restore"); + } + $CPAN::Frontend->myprint("\n\n"); + } + return($USER,$PASSWD); +} + +sub mirror { + my($self,$url,$aslocal) = @_; + my $result = $self->SUPER::mirror($url,$aslocal); + if ($result->code == 407) { + undef $USER; + undef $PASSWD; + $result = $self->SUPER::mirror($url,$aslocal); + } + $result; +} + package CPAN::FTP; #-> sub CPAN::FTP::ftp_get ; @@ -2163,9 +2224,10 @@ sub localize { # Inheritance is not easier to manage than a few if/else branches if ($CPAN::META->has_usable('LWP::UserAgent')) { unless ($Ua) { - eval {$Ua = LWP::UserAgent->new;}; # Why is has_usable still not fit enough? + CPAN::LWP::UserAgent->config; + eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough? if ($@) { - $CPAN::Frontent->mywarn("LWP::UserAgent->new dies with $@") + $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@") if $CPAN::DEBUG; } else { my($var); @@ -2173,6 +2235,20 @@ sub localize { if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; $Ua->proxy('http', $var) if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy}; + + +# >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" said: +# +# > I note that although CPAN.pm can use proxies, it doesn't seem equipped to +# > use ones that require basic autorization. +# +# > Example of when I use it manually in my own stuff: +# +# > $ua->proxy(['http','ftp'], http://my.proxy.server:83'); +# > $req->proxy_authorization_basic("username","password"); +# > $res = $ua->request($req); +# + $Ua->no_proxy($var) if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy}; } @@ -2275,6 +2351,7 @@ sub hosteasy { # meant # file://localhost $l =~ s|^/||s unless -f $l; # e.g. /P: + $self->debug("without URI::URL we try local file $l") if $CPAN::DEBUG; } if ( -f $l && -r _) { $Thesite = $i; @@ -2295,8 +2372,11 @@ sub hosteasy { $url "); unless ($Ua) { - require LWP::UserAgent; - $Ua = LWP::UserAgent->new; + CPAN::LWP::UserAgent->config; + eval { $Ua = CPAN::LWP::UserAgent->new; }; + if ($@) { + $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@"); + } } my $res = $Ua->mirror($url, $aslocal); if ($res->is_success) { @@ -2318,12 +2398,17 @@ sub hosteasy { return $aslocal; } } else { + $CPAN::Frontend->myprint(sprintf( + "LWP failed with code[%s] message[%s]\n", + $res->code, + $res->message, + )); # 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; + $CPAN::Frontend->myprint("LWP not available\n"); } return if $CPAN::Signal; if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) { @@ -2763,7 +2848,7 @@ sub cpl { my @return; if ($pos == 0) { @return = grep /^$word/, @CPAN::Complete::COMMANDS; - } elsif ( $line !~ /^[\!abcdhimorutl]/ ) { + } elsif ( $line !~ /^[\!abcdghimorutl]/ ) { @return = (); } elsif ($line =~ /^(a|ls)\s/) { @return = cplx('CPAN::Author',uc($word)); @@ -2773,7 +2858,7 @@ sub cpl { } elsif ($line =~ /^d\s/) { @return = cplx('CPAN::Distribution',$word); } elsif ($line =~ m/^( - [mru]|make|clean|dump|test|install|readme|look|cvs_import + [mru]|make|clean|dump|get|test|install|readme|look|cvs_import )\s/x ) { if ($word =~ /^Bundle::/) { CPAN::Shell->local_bundles; @@ -2850,7 +2935,7 @@ package CPAN::Index; #-> sub CPAN::Index::force_reload ; sub force_reload { my($class) = @_; - $CPAN::Index::last_time = 0; + $CPAN::Index::LAST_TIME = 0; $class->reload(1); } @@ -2875,9 +2960,9 @@ sub reload { } if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) { # warn "Setting last_time to 0"; - $last_time = 0; # No warning necessary + $LAST_TIME = 0; # No warning necessary } - return if $last_time + $CPAN::Config->{index_expire}*86400 > $time + return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time and ! $force; if (0) { # IFF we are developing, it helps to wipe out the memory @@ -2887,7 +2972,7 @@ sub reload { } { my($debug,$t2); - local $last_time = $time; + local $LAST_TIME = $time; local $CPAN::META->{PROTOCOL} = PROTOCOL; my $needshort = $^O eq "dos"; @@ -2927,7 +3012,7 @@ sub reload { $time = $t2; CPAN->debug($debug) if $CPAN::DEBUG; } - $last_time = $time; + $LAST_TIME = $time; $CPAN::META->{PROTOCOL} = PROTOCOL; } @@ -2999,12 +3084,12 @@ sub rd_modpacks { push @lines, @ls; } # read header - my $line_count; + my($line_count,$last_updated); while (@lines) { my $shift = shift(@lines); - $shift =~ /^Line-Count:\s+(\d+)/; - $line_count = $1 if $1; last if $shift =~ /^\s*$/; + $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1; + $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1; } if (not defined $line_count) { @@ -3024,6 +3109,41 @@ CPAN mirror. I'll continue but problems seem likely to happen.\a\n}, $index_target, $line_count, scalar(@lines); } + if (not defined $last_updated) { + + warn qq{Warning: Your $index_target does not contain a Last-Updated 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; + } else { + + $CPAN::Frontend + ->myprint(sprintf qq{ Database was generated on %s\n}, + $last_updated); + $DATE_OF_02 = $last_updated; + + if ($CPAN::META->has_inst(HTTP::Date)) { + require HTTP::Date; + my($age) = (time - HTTP::Date::str2time($last_updated))/3600/24; + if ($age > 30) { + + $CPAN::Frontend + ->mywarn(sprintf + qq{Warning: This index file is %d days old. + Please check the host you chose as your CPAN mirror for staleness. + I'll continue but problems seem likely to happen.\a\n}, + $age); + + } + } else { + $CPAN::Frontend->myprint(" HTTP::Date not available\n"); + } + } + + # A necessity since we have metadata_cache: delete what isn't # there anymore my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); @@ -3145,8 +3265,8 @@ sub rd_modlist { while (@eval) { my $shift = shift(@eval); if ($shift =~ /^Date:\s+(.*)/){ - return if $date_of_03 eq $1; - ($date_of_03) = $1; + return if $DATE_OF_03 eq $1; + ($DATE_OF_03) = $1; } last if $shift =~ /^\s*$/; } @@ -3177,7 +3297,8 @@ sub write_metadata_cache { $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok } my $metadata_file = MM->catfile($CPAN::Config->{cpan_home},"Metadata"); - $cache->{last_time} = $last_time; + $cache->{last_time} = $LAST_TIME; + $cache->{DATE_OF_02} = $DATE_OF_02; $cache->{PROTOCOL} = PROTOCOL; $CPAN::Frontend->myprint("Going to write $metadata_file\n"); eval { Storable::nstore($cache, $metadata_file) }; @@ -3196,7 +3317,7 @@ sub read_metadata_cache { eval { $cache = Storable::retrieve($metadata_file) }; $CPAN::Frontend->mywarn($@) if $@; if (!$cache || ref $cache ne 'HASH'){ - $last_time = 0; + $LAST_TIME = 0; return; } if (exists $cache->{PROTOCOL}) { @@ -3237,14 +3358,17 @@ sub read_metadata_cache { $CPAN::META->{PROTOCOL} ||= $cache->{PROTOCOL}; # reading does not up or downgrade, but it # does initialize to some protocol - $last_time = $cache->{last_time}; + $LAST_TIME = $cache->{last_time}; + $DATE_OF_02 = $cache->{DATE_OF_02}; + $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n"); + return; } package CPAN::InfoObj; # Accessors sub cpan_userid { shift->{RO}{CPAN_USERID} } -sub id { shift->{ID} } +sub id { shift->{ID}; } #-> sub CPAN::InfoObj::new ; sub new { @@ -3352,13 +3476,25 @@ sub dump { package CPAN::Author; +#-> sub CPAN::Author::id +sub id { + my $self = shift; + my $id = $self->{ID}; + $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/; + $id; +} + #-> sub CPAN::Author::as_glimpse ; sub as_glimpse { my($self) = @_; my(@m); my $class = ref($self); $class =~ s/^CPAN:://; - push @m, sprintf "%-15s %s (%s)\n", $class, $self->{ID}, $self->fullname; + push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n}, + $class, + $self->{ID}, + $self->fullname, + $self->email); join "", @m; } @@ -3377,31 +3513,49 @@ sub ls { my $id = $self->id; # adapted from CPAN::Distribution::verifyMD5 ; - my(@chksumfile); - @chksumfile = $self->id =~ /(.)(.)(.*)/; - $chksumfile[1] = join "", @chksumfile[0,1]; - $chksumfile[2] = join "", @chksumfile[1,2]; - push @chksumfile, "CHECKSUMS"; - print join "", map { + my(@csf); # chksumfile + @csf = $self->id =~ /(.)(.)(.*)/; + $csf[1] = join "", @csf[0,1]; + $csf[2] = join "", @csf[1,2]; + my(@dl); + @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0); + unless (grep {$_->[2] eq $csf[1]} @dl) { + $CPAN::Frontend->myprint("No files in the directory of $id\n"); + return; + } + @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0); + unless (grep {$_->[2] eq $csf[2]} @dl) { + $CPAN::Frontend->myprint("No files in the directory of $id\n"); + return; + } + @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1); + $CPAN::Frontend->myprint(join "", map { sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2]) - } sort { $a->[2] cmp $b->[2] } $self->dir_listing(\@chksumfile); + } sort { $a->[2] cmp $b->[2] } @dl); } +# returns an array of arrays, the latter contain (size,mtime,filename) #-> sub CPAN::Author::dir_listing ; sub dir_listing { my $self = shift; my $chksumfile = shift; + my $recursive = shift; my $lc_want = MM->catfile($CPAN::Config->{keep_source_where}, "authors", "id", @$chksumfile); local($") = "/"; + # connect "force" argument with "index_expire". + my $force = 0; + if (my @stat = stat $lc_want) { + $force = $stat[9] + $CPAN::Config->{index_expire}*86400 <= time; + } my $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", - $lc_want,1); + $lc_want,$force); unless ($lc_file) { $CPAN::Frontend->myprint("Trying $lc_want.gz\n"); $chksumfile->[-1] .= ".gz"; $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile", - "$lc_want.gz",1); + "$lc_want.gz",1); if ($lc_file) { $lc_file =~ s{\.gz(?!\n)\Z}{}; #}; CPAN::Tarzip->gunzip("$lc_file.gz",$lc_file); @@ -3430,12 +3584,16 @@ sub dir_listing { my(@result,$f); for $f (sort keys %$cksum) { if (exists $cksum->{$f}{isdir}) { - my(@dir) = @$chksumfile; - pop @dir; - push @dir, $f, "CHECKSUMS"; - push @result, map { - [$_->[0], $_->[1], "$f/$_->[2]"] - } $self->dir_listing(\@dir); + if ($recursive) { + my(@dir) = @$chksumfile; + pop @dir; + push @dir, $f, "CHECKSUMS"; + push @result, map { + [$_->[0], $_->[1], "$f/$_->[2]"] + } $self->dir_listing(\@dir,1); + } else { + push @result, [ 0, "-", $f ]; + } } else { push @result, [ ($cksum->{$f}{"size"}||0), @@ -3461,8 +3619,12 @@ sub undelay { sub normalize { my($self,$s) = @_; $s = $self->id unless defined $s; - if ($s =~ tr|/|| == 1) { - return $s if $s =~ m|^N/A|; + if ( + $s =~ tr|/|| == 1 + or + $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/| + ) { + return $s if $s =~ m:^N/A|^Contact Author: ; $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or $CPAN::Frontend->mywarn("Strange distribution name [$s]"); CPAN->debug("s[$s]") if $CPAN::DEBUG; @@ -3540,7 +3702,7 @@ sub called_for { return $self->{CALLED_FOR}; } -#-> sub CPAN::Distribution::my_chdir ; +#-> sub CPAN::Distribution::safe_chdir ; sub safe_chdir { my($self,$todir) = @_; # we die if we cannot chdir and we are debuggable @@ -3581,9 +3743,16 @@ sub get { ); $self->debug("Doing localize") if $CPAN::DEBUG; - $local_file = - CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted) - or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n"); + unless ($local_file = + CPAN::FTP->localize("authors/id/$self->{ID}", + $local_wanted)) { + my $note = ""; + if ($CPAN::Index::DATE_OF_02) { + $note = "Note: Current database in memory was generated ". + "on $CPAN::Index::DATE_OF_02\n"; + } + $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note"); + } $self->debug("local_file[$local_file]") if $CPAN::DEBUG; $self->{localfile} = $local_file; return if $CPAN::Signal; @@ -3684,12 +3853,14 @@ sub get { my($mpl) = MM->catfile($packagedir,"Makefile.PL"); my($mpl_exists) = -f $mpl; unless ($mpl_exists) { - # Steffen's stupid NFS has problems to see an existing - # Makefile.PL such a short time after the directory was - # renamed. Maybe this trick helps - $dh = DirHandle->new($packagedir) + # NFS has been reported to have racing problems after the + # renaming of a directory in some environments. + # This trick helps. + sleep 1; + my $mpldh = DirHandle->new($packagedir) or Carp::croak("Couldn't opendir $packagedir: $!"); - $mpl_exists = grep /^Makefile\.PL$/, $dh->read; + $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read; + $mpldh->close; } unless ($mpl_exists) { $self->debug(sprintf("makefilepl[%s]anycwd[%s]", @@ -3808,14 +3979,22 @@ Please define it with "o conf shell " return; } my $dist = $self->id; - my $dir = $self->dir or $self->get; - $dir = $self->dir; + my $dir; + unless ($dir = $self->dir) { + $self->get; + } + unless ($dir ||= $self->dir) { + $CPAN::Frontend->mywarn(qq{ +Could not determine which directory to use for looking at $dist. +}); + return; + } my $pwd = CPAN::anycwd(); - chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!}); + $self->safe_chdir($dir); $CPAN::Frontend->myprint(qq{Working directory is $dir\n}); system($CPAN::Config->{'shell'}) == 0 or $CPAN::Frontend->mydie("Subprocess shell error"); - chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!}); + $self->safe_chdir($pwd); } # CPAN::Distribution::cvs_import ; @@ -4613,59 +4792,65 @@ sub as_string { #-> sub CPAN::Bundle::contains ; sub contains { - my($self) = @_; - my($parsefile) = $self->inst_file || ""; - my($id) = $self->id; - $self->debug("parsefile[$parsefile]id[$id]") if $CPAN::DEBUG; - unless ($parsefile) { - # Try to get at it in the cpan directory - $self->debug("no parsefile") if $CPAN::DEBUG; - Carp::confess "I don't know a $id" unless $self->cpan_file; - my $dist = $CPAN::META->instance('CPAN::Distribution', - $self->cpan_file); - $dist->get; - $self->debug($dist->as_string) if $CPAN::DEBUG; - my($todir) = $CPAN::Config->{'cpan_home'}; - my(@me,$from,$to,$me); - @me = split /::/, $self->id; - $me[-1] .= ".pm"; - $me = MM->catfile(@me); - $from = $self->find_bundle_file($dist->{'build_dir'},$me); - $to = MM->catfile($todir,$me); - File::Path::mkpath(File::Basename::dirname($to)); - File::Copy::copy($from, $to) - or Carp::confess("Couldn't copy $from to $to: $!"); - $parsefile = $to; - } - my @result; - my $fh = FileHandle->new; - local $/ = "\n"; - open($fh,$parsefile) or die "Could not open '$parsefile': $!"; - my $in_cont = 0; - $self->debug("parsefile[$parsefile]") if $CPAN::DEBUG; - while (<$fh>) { - $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]; - } - close $fh; - delete $self->{STATUS}; - $self->{CONTAINS} = \@result; - $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; - unless (@result) { - $CPAN::Frontend->mywarn(qq{ -The bundle file "$parsefile" may be a broken + my($self) = @_; + my($inst_file) = $self->inst_file || ""; + my($id) = $self->id; + $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG; + unless ($inst_file) { + # Try to get at it in the cpan directory + $self->debug("no inst_file") if $CPAN::DEBUG; + my $cpan_file; + $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless + $cpan_file = $self->cpan_file; + if ($cpan_file eq "N/A") { + $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. + Maybe stale symlink? Maybe removed during session? Giving up.\n"); + } + my $dist = $CPAN::META->instance('CPAN::Distribution', + $self->cpan_file); + $dist->get; + $self->debug($dist->as_string) if $CPAN::DEBUG; + my($todir) = $CPAN::Config->{'cpan_home'}; + my(@me,$from,$to,$me); + @me = split /::/, $self->id; + $me[-1] .= ".pm"; + $me = MM->catfile(@me); + $from = $self->find_bundle_file($dist->{'build_dir'},$me); + $to = MM->catfile($todir,$me); + File::Path::mkpath(File::Basename::dirname($to)); + File::Copy::copy($from, $to) + or Carp::confess("Couldn't copy $from to $to: $!"); + $inst_file = $to; + } + my @result; + my $fh = FileHandle->new; + local $/ = "\n"; + open($fh,$inst_file) or die "Could not open '$inst_file': $!"; + my $in_cont = 0; + $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG; + while (<$fh>) { + $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]; + } + close $fh; + delete $self->{STATUS}; + $self->{CONTAINS} = \@result; + $self->debug("CONTAINS[@result]") if $CPAN::DEBUG; + unless (@result) { + $CPAN::Frontend->mywarn(qq{ +The bundle file "$inst_file" may be a broken bundlefile. It seems not to contain any bundle definition. Please check the file and if it is bogus, please delete it. Sorry for the inconvenience. }); - } - @result; + } + @result; } #-> sub CPAN::Bundle::find_bundle_file @@ -5017,8 +5202,11 @@ sub as_string { # warn "dist[$dist]"; # mff=manifest file; mfh=manifest handle my($mff,$mfh); - if ($dist->{build_dir} and - -f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST")) and + if ( + $dist->{build_dir} + and + (-f ($mff = MM->catfile($dist->{build_dir}, "MANIFEST"))) + and $mfh = FileHandle->new($mff) ) { CPAN->debug("mff[$mff]") if $CPAN::DEBUG; @@ -5091,7 +5279,8 @@ sub manpage_headline { } #-> sub CPAN::Module::cpan_file ; -sub cpan_file { +# Note: also inherited by CPAN::Bundle +sub cpan_file { my $self = shift; CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG; unless (defined $self->{RO}{CPAN_FILE}) { @@ -5797,6 +5986,13 @@ displays the README file of the associated distribution. C gets and untars (if not yet done) the distribution file, changes to the appropriate directory and opens a subshell process in that directory. +=item ls author + +C lists all distribution files in and below an author's CPAN +directory. Only those files that contain modules are listed and if +there is more than one for any given module, only the most recent one +is listed. + =item Signals CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are @@ -6420,6 +6616,8 @@ defined: prerequisites_policy what to do if you are missing module prerequisites ('follow' automatically, 'ask' me, or 'ignore') + proxy_user username for accessing an authenticating proxy + proxy_pass password for accessing an authenticating proxy scan_cache controls scanning of cache ('atstart' or 'never') tar location of external program tar term_is_latin if true internal UTF-8 is translated to ISO-8859-1 @@ -6766,7 +6964,7 @@ becomes stable with regard to charset issues. We should give coverage for B 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/, modules/ and scripts/. CPAN is +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 @@ -6781,6 +6979,11 @@ traditional method of building a Perl module package from a shell. Andreas Koenig Eandreas.koenig@anima.deE +=head1 TRANSLATIONS + +Kawai,Takanori provides a Japanese translation of this manpage at +http://member.nifty.ne.jp/hippo2000/perltips/CPAN.htm + =head1 SEE ALSO perl(1), CPAN::Nox(3) diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm index 7cf01cd..0429db1 100644 --- a/lib/CPAN/FirstTime.pm +++ b/lib/CPAN/FirstTime.pm @@ -17,7 +17,7 @@ use FileHandle (); use File::Basename (); use File::Path (); use vars qw($VERSION); -$VERSION = substr q$Revision: 1.51 $, 10; +$VERSION = substr q$Revision: 1.53 $, 10; =head1 NAME @@ -204,7 +204,7 @@ software to CPAN bear names that are outside the ASCII range. If your terminal supports UTF-8, you say no to the next question, if it supports ISO-8859-1 (also known as LATIN1) then you say yes, and if it supports neither nor, your answer does not matter, you will not be -able to read the names of some authors anyway. If you answer no, nmes +able to read the names of some authors anyway. If you answer no, names will be output in UTF-8. }; @@ -384,6 +384,44 @@ the \$CPAN::Config takes precedence. $CPAN::Config->{$_} = prompt("Your $_?",$default); } + if ($CPAN::Config->{ftp_proxy} || + $CPAN::Config->{http_proxy}) { + $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER; + print qq{ + +If your proxy is an authenticating proxy, you can store your username +permanently. If you do not want that, just press RETURN. You will then +be asked for your username in every future session. + +}; + if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) { + print qq{ + +Your password for the authenticating proxy can also be stored +permanently on disk. If this violates your security policy, just press +RETURN. You will then be asked for the password in every future +session. + +}; + + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("noecho"); + } else { + print qq{ + +Warning: Term::ReadKey seems not to be available, your password will +be echoed to the terminal! + +}; + } + $CPAN::Config->{proxy_pass} = prompt("Your proxy password?"); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("restore"); + } + $CPAN::Frontend->myprint("\n\n"); + } + } + # # MIRRORED.BY # @@ -426,11 +464,11 @@ sub conf_sites { my $mtime = localtime((stat _)[9]); my $prompt = qq{Found $mby as of $mtime - I\'d use that as a database of CPAN sites. If that is OK for you, - please answer 'y', but if you want me to get a new database now, - please answer 'n' to the following question. +I\'d use that as a database of CPAN sites. If that is OK for you, +please answer 'y', but if you want me to get a new database now, +please answer 'n' to the following question. - Shall I use the local database in $mby?}; +Shall I use the local database in $mby?}; my $ans = prompt($prompt,"y"); $overwrite_local = 1 unless $ans =~ /^y/i; }