Upgrade to CPAN 1.70_54

Subject: Re: CPAN.pm into blead
Message-ID: <87of1y6k2j.fsf@franz.ak.mind.de>

p4raw-id: //depot/perl@19573

1 files changed, 101 insertions, 60 deletions

diff --git a/lib/CPAN.pm b/lib/CPAN.pm
index 0abfe1d8e7..56d2e63831 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.64';
-# $Id: CPAN.pm,v 1.397 2003/02/06 09:44:40 k Exp $
+$VERSION = '1.70_54';
+# $Id: CPAN.pm,v 1.404 2003/05/15 20:43:14 k Exp $
 
 # only used during development:
 $Revision = "";
-# $Revision = "[".substr(q$Revision: 1.397 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.404 $, 10)."]";
 
 use Carp ();
 use Config ();
@@ -281,6 +281,28 @@ package CPAN::Bundle;
 package CPAN::Module;
 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 
+package CPAN::Exception::RecursiveDependency;
+use overload '""' => "as_string";
+
+sub new {
+    my($class) = shift;
+    my($deps) = shift;
+    my @deps;
+    my %seen;
+    for my $dep (@$deps) {
+        push @deps, $dep;
+        last if $seen{$dep}++;
+    }
+    bless { deps => \@deps }, $class;
+}
+
+sub as_string {
+    my($self) = shift;
+    "\nRecursive dependency detected:\n    " .
+        join("\n => ", @{$self->{deps}}) .
+            ".\nCannot continue.\n";
+}
+
 package CPAN::Shell;
 use vars qw($AUTOLOAD @ISA $COLOR_REGISTERED $ADVANCED_QUERY $PRINT_ORNAMENTING);
 @CPAN::Shell::ISA = qw(CPAN::Debug);
@@ -803,14 +825,18 @@ sub savehist {
         return;
     }
     $histsize = $CPAN::Config->{'histsize'} || 100;
-    unless ($CPAN::term->can("GetHistory")) {
-        $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
+    if ($CPAN::term){
+        unless ($CPAN::term->can("GetHistory")) {
+            $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
+            return;
+        }
+    } else {
         return;
     }
     my @h = $CPAN::term->GetHistory;
     splice @h, 0, @h-$histsize if @h>$histsize;
     my($fh) = FileHandle->new;
-    open $fh, ">$histfile" or mydie("Couldn't open >$histfile: $!");
+    open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
     local $\ = local $, = "\n";
     print $fh @h;
     close $fh;
@@ -1419,7 +1445,8 @@ sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
 
 #-> sub CPAN::Shell::m ;
 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
-    $CPAN::Frontend->myprint(shift->format_result('Module',@_));
+    my $self = shift;
+    $CPAN::Frontend->myprint($self->format_result('Module',@_));
 }
 
 #-> sub CPAN::Shell::i ;
@@ -2335,10 +2362,9 @@ sub localize {
             }
 	}
     }
-    $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};
+    for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
+        $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
+    }
 
     # Try the list of urls for each single object. We keep a record
     # where we did get a file from
@@ -2664,8 +2690,9 @@ sub hosthardest {
     my($i);
     my($aslocal_dir) = File::Basename::dirname($aslocal);
     File::Path::mkpath($aslocal_dir);
+    my $ftpbin = $CPAN::Config->{ftp};
   HOSTHARDEST: for $i (@$host_seq) {
-	unless (length $CPAN::Config->{'ftp'}) {
+	unless (length $ftpbin && MM->maybe_command($ftpbin)) {
 	    $CPAN::Frontend->myprint("No external ftp command available\n\n");
 	    last HOSTHARDEST;
 	}
@@ -2710,7 +2737,7 @@ sub hosthardest {
 
 }
 		     );
-		$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose $host",
+		$self->talk_ftp("$ftpbin$verbose $host",
 				@dialog);
 		($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 		 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
@@ -2735,13 +2762,13 @@ sub hosthardest {
 	# OK, they don't have a valid ~/.netrc. Use 'ftp -n'
 	# then and login manually to host, using e-mail as
 	# password.
-	$CPAN::Frontend->myprint(qq{Issuing "$CPAN::Config->{'ftp'}$verbose -n"\n});
+	$CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
 	unshift(
 		@dialog,
 		"open $host",
 		"user anonymous $Config::Config{'cf_email'}"
 	       );
-	$self->talk_ftp("$CPAN::Config->{'ftp'}$verbose -n", @dialog);
+	$self->talk_ftp("$ftpbin$verbose -n", @dialog);
 	($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 	 $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
 	$mtime ||= 0;
@@ -3286,7 +3313,7 @@ happen.\a
 	if ($id->cpan_file ne $dist){ # update only if file is
                                       # different. CPAN prohibits same
                                       # name with different version
-	    $userid = $self->userid($dist);
+	    $userid = $id->userid || $self->userid($dist);
 	    $id->set(
 		     'CPAN_USERID' => $userid,
 		     'CPAN_VERSION' => $version,
@@ -3452,7 +3479,11 @@ sub read_metadata_cache {
 package CPAN::InfoObj;
 
 # Accessors
-sub cpan_userid { shift->{RO}{CPAN_USERID} }
+sub cpan_userid {
+    my $self = shift;
+    $self->{RO}{CPAN_USERID}
+}
+
 sub id { shift->{ID}; }
 
 #-> sub CPAN::InfoObj::new ;
@@ -3722,22 +3753,20 @@ sub color_cmd_tmps {
     my($self) = shift;
     my($depth) = shift || 0;
     my($color) = shift || 0;
+    my($ancestors) = shift || [];
     # a distribution needs to recurse into its prereq_pms
 
     return if exists $self->{incommandcolor}
         && $self->{incommandcolor}==$color;
-    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
-                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
-                                   $depth,
-                                   $self,
-                                   $self->id
-                                  )) if $depth>=100;
-    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+    if ($depth>=100){
+        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
+    }
+    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
     my $prereq_pm = $self->prereq_pm;
     if (defined $prereq_pm) {
         for my $pre (keys %$prereq_pm) {
             my $premo = CPAN::Shell->expand("Module",$pre);
-            $premo->color_cmd_tmps($depth+1,$color);
+            $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
         }
     }
     if ($color==0) {
@@ -4077,8 +4106,10 @@ Could not determine which directory to use for looking at $dist.
     my $pwd  = CPAN::anycwd();
     $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");
+    unless (system($CPAN::Config->{'shell'}) == 0) {
+        my $code = $? >> 8;
+        $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
+    }
     $self->safe_chdir($pwd);
 }
 
@@ -4553,6 +4584,7 @@ of modules we are processing right now?", "yes");
     if ($follow) {
         # color them as dirty
         for my $p (@prereq) {
+            # warn "calling color_cmd_tmps(0,1)";
             CPAN::Shell->expandany($p)->color_cmd_tmps(0,1);
         }
         CPAN::Queue->jumpqueue(@prereq,$id); # queue them and requeue yourself
@@ -4834,10 +4866,7 @@ package CPAN::Bundle;
 
 sub look {
     my $self = shift;
-    $CPAN::Frontend->myprint(
-                             qq{ look() commmand on bundles not}.
-                             qq{ implemented (What should it do?)}
-                            );
+    $CPAN::Frontend->myprint($self->as_string);
 }
 
 sub undelay {
@@ -4854,23 +4883,21 @@ sub color_cmd_tmps {
     my($self) = shift;
     my($depth) = shift || 0;
     my($color) = shift || 0;
+    my($ancestors) = shift || [];
     # a module needs to recurse to its cpan_file, a distribution needs
     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
 
     return if exists $self->{incommandcolor}
         && $self->{incommandcolor}==$color;
-    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
-                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
-                                   $depth,
-                                   $self,
-                                   $self->id
-                                  )) if $depth>=100;
-    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+    if ($depth>=100){
+        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
+    }
+    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
 
     for my $c ( $self->contains ) {
         my $obj = CPAN::Shell->expandany($c) or next;
         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
-        $obj->color_cmd_tmps($depth+1,$color);
+        $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
     }
     if ($color==0) {
         delete $self->{badtestcnt};
@@ -5160,12 +5187,13 @@ No File found for bundle } . $self->id . qq{\n}), return;
 package CPAN::Module;
 
 # Accessors
-# sub cpan_userid { shift->{RO}{CPAN_USERID} }
+# sub CPAN::Module::userid
 sub userid {
     my $self = shift;
     return unless exists $self->{RO}; # should never happen
-    return $self->{RO}{CPAN_USERID} || $self->{RO}{userid};
+    return $self->{RO}{userid} || $self->{RO}{CPAN_USERID};
 }
+# sub CPAN::Module::description
 sub description { shift->{RO}{description} }
 
 sub undelay {
@@ -5181,20 +5209,18 @@ sub color_cmd_tmps {
     my($self) = shift;
     my($depth) = shift || 0;
     my($color) = shift || 0;
+    my($ancestors) = shift || [];
     # a module needs to recurse to its cpan_file
 
     return if exists $self->{incommandcolor}
         && $self->{incommandcolor}==$color;
-    $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: deep recursion in ".
-                                   "color_cmd_tmps depth[%s] self[%s] id[%s]",
-                                   $depth,
-                                   $self,
-                                   $self->id
-                                  )) if $depth>=100;
-    ##### warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
+    if ($depth>=100){
+        $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
+    }
+    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
 
     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
-        $dist->color_cmd_tmps($depth+1,$color);
+        $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
     }
     if ($color==0) {
         delete $self->{badtestcnt};
@@ -5233,7 +5259,7 @@ sub as_glimpse {
 sub as_string {
     my($self) = @_;
     my(@m);
-    CPAN->debug($self) if $CPAN::DEBUG;
+    CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
     my $class = ref($self);
     $class =~ s/^CPAN:://;
     local($^W) = 0;
@@ -5243,7 +5269,8 @@ sub as_string {
 	if $self->description;
     my $sprintf2 = "    %-12s %s (%s)\n";
     my($userid);
-    if ($userid = $self->cpan_userid || $self->userid){
+    $userid = $self->userid;
+    if ( $userid ){
 	my $author;
 	if ($author = CPAN::Shell->expand('Author',$userid)) {
 	  my $email = "";
@@ -5267,8 +5294,8 @@ sub as_string {
     my(%statd,%stats,%statl,%stati);
     @statd{qw,? i c a b R M S,} = qw,unknown idea
 	pre-alpha alpha beta released mature standard,;
-    @stats{qw,? m d u n,}       = qw,unknown mailing-list
-	developer comp.lang.perl.* none,;
+    @stats{qw,? m d u n a,}       = qw,unknown mailing-list
+	developer comp.lang.perl.* none abandoned,;
     @statl{qw,? p c + o h,}       = qw,unknown perl C C++ other hybrid,;
     @stati{qw,? f r O h,}         = qw,unknown functions
 	references+ties object-oriented hybrid,;
@@ -5507,6 +5534,13 @@ sub install {
     } else {
 	$doit = 1;
     }
+    if ($self->{RO}{stats} && $self->{RO}{stats} eq "a") {
+        $CPAN::Frontend->mywarn(qq{
+\n\n\n     ***WARNING***
+     The module $self->{ID} has no active maintainer.\n\n\n
+});
+        sleep 5;
+    }
     $self->rematein('install') if $doit;
 }
 #-> sub CPAN::Module::clean ;
@@ -5972,7 +6006,7 @@ stalled.
 =head1 DESCRIPTION
 
 The CPAN module is designed to automate the make and install of perl
-modules and extensions. It includes some searching capabilities and
+modules and extensions. It includes some primitive searching capabilities and
 knows how to use Net::FTP or LWP (or lynx or an external ftp client)
 to fetch the raw data from the net.
 
@@ -6693,12 +6727,19 @@ with this floppy. See also below the paragraph about CD-ROM support.
 
 =head1 CONFIGURATION
 
-When the CPAN module is installed, a site wide configuration file is
-created as CPAN/Config.pm. The default values defined there can be
-overridden in another configuration file: CPAN/MyConfig.pm. You can
-store this file in $HOME/.cpan/CPAN/MyConfig.pm if you want, because
-$HOME/.cpan is added to the search path of the CPAN module before the
-use() or require() statements.
+When the CPAN module is used for the first time, a configuration
+dialog tries to determine a couple of site specific options. The
+result of the dialog is stored in a hash reference C< $CPAN::Config >
+in a file CPAN/Config.pm.
+
+The default values defined in the CPAN/Config.pm file can be
+overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
+best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
+added to the search path of the CPAN module before the use() or
+require() statements.
+
+The configuration dialog can be started any time later again by
+issueing the command C< o conf init > in the CPAN shell.
 
 Currently the following keys in the hash reference $CPAN::Config are
 defined: