X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCPAN.pm;h=b628386d267860fed33b0ba58a879953dae588db;hb=83272a45226e83bd136d713158e9b44ace2dbc8d;hp=cde8389733f9f7f75d6a34c65497aa70c50bdaba;hpb=5de3f0dafce89a8a66760745213b4c2a7a75c731;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/CPAN.pm b/lib/CPAN.pm
index cde8389..b628386 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_56';
-# $Id: CPAN.pm,v 1.385 2001/02/09 21:37:57 k Exp $
+$VERSION = '1.61';
+# $Id: CPAN.pm,v 1.390 2002/05/07 10:04:58 k Exp $
 
 # only used during development:
 $Revision = "";
-# $Revision = "[".substr(q$Revision: 1.385 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.390 $, 10)."]";
 
 use Carp ();
 use Config ();
@@ -22,6 +22,7 @@ use Safe ();
 use Text::ParseWords ();
 use Text::Wrap;
 use File::Spec;
+use Sys::Hostname;
 no lib "."; # we need to run chdir all over and we would get at wrong
             # libraries there
 
@@ -460,19 +461,33 @@ sub checklock {
     if (-f $lockfile && -M _ > 0) {
 	my $fh = FileHandle->new($lockfile) or
             $CPAN::Frontend->mydie("Could not open $lockfile: $!");
-	my $other = <$fh>;
+	my $otherpid  = <$fh>;
+	my $otherhost = <$fh>;
 	$fh->close;
-	if (defined $other && $other) {
-	    chomp $other;
-	    return if $$==$other; # should never happen
+	if (defined $otherpid && $otherpid) {
+	    chomp $otherpid;
+        }
+	if (defined $otherhost && $otherhost) {
+	    chomp $otherhost;
+	}
+	my $thishost  = hostname();
+	if (defined $otherhost && defined $thishost &&
+	    $otherhost ne '' && $thishost ne '' &&
+	    $otherhost ne $thishost) {
+            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
+                                           "reports other host $otherhost and other process $otherpid.\n".
+                                           "Cannot proceed.\n"));
+	}
+	elsif (defined $otherpid && $otherpid) {
+	    return if $$ == $otherpid; # should never happen
 	    $CPAN::Frontend->mywarn(
 				    qq{
-There seems to be running another CPAN process ($other). Contacting...
+There seems to be running another CPAN process (pid $otherpid).  Contacting...
 });
-	    if (kill 0, $other) {
+	    if (kill 0, $otherpid) {
 		$CPAN::Frontend->mydie(qq{Other job is running.
 You may want to kill it and delete the lockfile, maybe. On UNIX try:
-    kill $other
+    kill $otherpid
     rm $lockfile
 });
 	    } elsif (-w $lockfile) {
@@ -492,9 +507,9 @@ You may want to kill it and delete the lockfile, maybe. On UNIX try:
 			   );
 	    }
 	} else {
-            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile ".
+            $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile $lockfile\n".
                                            "reports other process with ID ".
-                                           "$other. Cannot proceed.\n"));
+                                           "$otherpid. Cannot proceed.\n"));
         }
     }
     my $dotcpan = $CPAN::Config->{cpan_home};
@@ -558,6 +573,7 @@ or
 	$CPAN::Frontend->mydie("Could not open >$lockfile: $!");
     }
     $fh->print($$, "\n");
+    $fh->print(hostname(), "\n");
     $self->{LOCK} = $lockfile;
     $fh->close;
     $SIG{TERM} = sub {
@@ -770,6 +786,29 @@ sub cleanup {
   $CPAN::Frontend->mywarn("Lockfile removed.\n");
 }
 
+sub is_tested {
+    my($self,$what) = @_;
+    $self->{is_tested}{$what} = 1;
+}
+
+sub is_installed {
+    my($self,$what) = @_;
+    delete $self->{is_tested}{$what};
+}
+
+sub set_perl5lib {
+    my($self) = @_;
+    $self->{is_tested} ||= {};
+    return unless %{$self->{is_tested}};
+    my $env = $ENV{PERL5LIB};
+    $env = $ENV{PERLLIB} unless defined $env;
+    my @env;
+    push @env, $env if defined $env and length $env;
+    my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
+    $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+    $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
+}
+
 package CPAN::CacheMgr;
 
 #-> sub CPAN::CacheMgr::as_string ;
@@ -1095,6 +1134,36 @@ sub init {
     1;
 }
 
+# This is a piece of repeated code that is abstracted here for
+# maintainability.  RMB
+#
+sub _configpmtest {
+    my($configpmdir, $configpmtest) = @_; 
+    if (-w $configpmtest) {
+        return $configpmtest;
+    } elsif (-w $configpmdir) {
+        #_#_# following code dumped core on me with 5.003_11, a.k.
+        my $configpm_bak = "$configpmtest.bak";
+        unlink $configpm_bak if -f $configpm_bak;
+        if( -f $configpmtest ) {	
+            if( rename $configpmtest, $configpm_bak ) {  
+                $CPAN::Frontend->mywarn(<<END)
+Old configuration file $configpmtest
+    moved to $configpm_bak
+END
+	    }
+	}	
+	my $fh = FileHandle->new;
+	if ($fh->open(">$configpmtest")) {
+	    $fh->print("1;\n");
+	    return $configpmtest;
+	} else {
+	    # Should never happen
+	    Carp::confess("Cannot open >$configpmtest");
+	}
+    } else { return } 
+}
+
 #-> sub CPAN::Config::load ;
 sub load {
     my($self) = shift;
@@ -1125,39 +1194,14 @@ sub load {
 	my($configpmdir) = File::Spec->catdir($path_to_cpan,"CPAN");
 	my($configpmtest) = File::Spec->catfile($configpmdir,"Config.pm");
 	if (-d $configpmdir or File::Path::mkpath($configpmdir)) {
-	    if (-w $configpmtest) {
-		$configpm = $configpmtest;
-	    } elsif (-w $configpmdir) {
-		#_#_# following code dumped core on me with 5.003_11, a.k.
-		unlink "$configpmtest.bak" if -f "$configpmtest.bak";
-		rename $configpmtest, "$configpmtest.bak" if -f $configpmtest;
-		my $fh = FileHandle->new;
-		if ($fh->open(">$configpmtest")) {
-		    $fh->print("1;\n");
-		    $configpm = $configpmtest;
-		} else {
-		    # Should never happen
-		    Carp::confess("Cannot open >$configpmtest");
-		}
-	    }
+	    $configpm = _configpmtest($configpmdir,$configpmtest); 
 	}
 	unless ($configpm) {
 	    $configpmdir = File::Spec->catdir($ENV{HOME},".cpan","CPAN");
 	    File::Path::mkpath($configpmdir);
 	    $configpmtest = File::Spec->catfile($configpmdir,"MyConfig.pm");
-	    if (-w $configpmtest) {
-		$configpm = $configpmtest;
-	    } elsif (-w $configpmdir) {
-		#_#_# following code dumped core on me with 5.003_11, a.k.
-		my $fh = FileHandle->new;
-		if ($fh->open(">$configpmtest")) {
-		    $fh->print("1;\n");
-		    $configpm = $configpmtest;
-		} else {
-		    # Should never happen
-		    Carp::confess("Cannot open >$configpmtest");
-		}
-	    } else {
+	    $configpm = _configpmtest($configpmdir,$configpmtest); 
+	    unless ($configpm) {
 		Carp::confess(qq{WARNING: CPAN.pm is unable to }.
 			      qq{create a configuration file.});
 	    }
@@ -2072,7 +2116,7 @@ sub config {
         @ISA = qw(Exporter LWP::UserAgent);
         $SETUPDONE++;
     } else {
-        $CPAN::Frontent->mywarn("LWP::UserAgent not available\n");
+        $CPAN::Frontend->mywarn("LWP::UserAgent not available\n");
     }
 }
 
@@ -2229,7 +2273,7 @@ sub localize {
             CPAN::LWP::UserAgent->config;
 	    eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
             if ($@) {
-                $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@")
+                $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@")
                     if $CPAN::DEBUG;
             } else {
                 my($var);
@@ -2265,6 +2309,9 @@ sub localize {
     # where we did get a file from
     my(@reordered,$last);
     $CPAN::Config->{urllist} ||= [];
+    unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
+        warn "Malformed urllist; ignoring.  Configuration file corrupt?\n";
+    }
     $last = $#{$CPAN::Config->{urllist}};
     if ($force & 2) { # local cpans probably out of date, don't reorder
 	@reordered = (0..$last);
@@ -2377,7 +2424,7 @@ sub hosteasy {
               CPAN::LWP::UserAgent->config;
               eval { $Ua = CPAN::LWP::UserAgent->new; };
               if ($@) {
-                  $CPAN::Frontent->mywarn("CPAN::LWP::UserAgent->new dies with $@");
+                  $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@");
               }
 	  }
 	  my $res = $Ua->mirror($url, $aslocal);
@@ -2509,7 +2556,7 @@ Trying with "$funkyftp$src_switch" to get
     $url
 ]);
 	  my($system) =
-	      "$chdir$funkyftp$src_switch '$url' $devnull$stdout_redir";
+	      "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
 	  $self->debug("system[$system]") if $CPAN::DEBUG;
 	  my($wstatus);
 	  if (($wstatus = system($system)) == 0
@@ -2542,7 +2589,7 @@ Trying with "$funkyftp$src_switch" to get
 Trying with "$funkyftp$src_switch" to get
   $url.gz
 ]);
-	    my($system) = "$funkyftp$src_switch '$url.gz' $devnull > $asl_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
@@ -4609,9 +4656,12 @@ sub test {
         return;
     }
 
+    local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
+    $CPAN::META->set_perl5lib;
     my $system = join " ", $CPAN::Config->{'make'}, "test";
     if (system($system) == 0) {
 	 $CPAN::Frontend->myprint("  $system -- OK\n");
+	 $CPAN::META->is_tested($self->{'build_dir'});
 	 $self->{make_test} = "YES";
     } else {
 	 $self->{make_test} = "NO";
@@ -4727,6 +4777,7 @@ sub install {
     $pipe->close;
     if ($?==0) {
 	 $CPAN::Frontend->myprint("  $system -- OK\n");
+	 $CPAN::META->is_installed($self->{'build_dir'});
 	 return $self->{'install'} = "YES";
     } else {
 	 $self->{'install'} = "NO";
@@ -4746,6 +4797,14 @@ sub dir {
 
 package CPAN::Bundle;
 
+sub look {
+    my $self = shift;
+    $CPAN::Frontend->myprint(
+                             qq{ look() commmand on bundles not}.
+                             qq{ implemented (What should it do?)}
+                            );
+}
+
 sub undelay {
     my $self = shift;
     delete $self->{later};
@@ -5267,8 +5326,8 @@ sub manpage_headline {
     my $inpod = 0;
     local $/ = "\n";
     while (<$fh>) {
-      $inpod = m/^=(?!head1\s+NAME)/ ? 0 :
-	  m/^=head1\s+NAME/ ? 1 : $inpod;
+      $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
+	  m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
       next unless $inpod;
       next if /^=/;
       next if /^\s+$/;