develooper Front page | perl.perl5.porters | Postings from October 2003

[PATCH 1.76] CPAN.pm improvements

Thread Next
From:
Ilya Zakharevich
Date:
October 12, 2003 15:23
Subject:
[PATCH 1.76] CPAN.pm improvements
Message ID:
20031012222314.GA11969@math.berkeley.edu
OK, now I'm more or less satisfied with the state of CPAN.pm on my
system.  Finally, it allows a convenient operation for testing a new
Perl build.  Attached is the patch.  Description:

a) index_expire was overwritten during interactive-reconfigure;

b) new configuration variables:

     expire_old_builds - controls new functionality (persistent state
			 for "we already tested this distribution");

     test_uptodate and install_uptodate:

		       - control whether one should ignore
                         test/install requests for
                         modules/distributions/bundles which are known
                         to be uptodate;

	The default is the same as now: test always, install
	distributions and bundles.  The value is a string; if contains
	words modules distributions bundles, this causes effect on the
	corresponding operation.

c) New command `install_tested'.  Runs `install' over distributions
   which are in "persistently known to be tested" state.

d) Fixes bugs with the "put ./blib of tested in this session, but
   uninstalled distributions to @INC when working with a distribution"
   logic.  I do not know how logic of interaction of PERL5LIB with
   PERLLIB worked before (due to coincidence only?).  Moreover, the
   changes were not done during Makefile.PL'ing, and during `make';
   only during `make test'.

   Moreover, the algorithm of finding missing prerequisites was not
   taking into account those already tested distributions.  Fixed.
   Now one can reliably test large bundles (mine is of about 100
   distributions) without doing `make install'.

e) Special commands to `o conf' are printed with distinguishing indent;

f) The logic of persistent "tested-ok" state is the following one:
   distributions which were ever tested_ok are indexed in ./Metadata
   hash, with values being the build-directories.  [One could use glob
   '*/.cpantok' instead...]  When we need to test a distribution, we
   check the build directory for this file.  The file serves two
   purposes: first of all, it is a timestamp; we check that no
   modification was done to any file after this timestamp.  Second, it
   is a snapshot of the version of Perl used to test this directory;
   we check that it coincides with the snapshot of "this perl".

   If both tests pass, we check the configuration variable
   expire_old_builds; if the test was recent enough, we declare test
   successful without any further operation with the distribution.

   [Currently the snapshot consists of sitearchexp, the name of the
   perl executable (and a DLL if found), and the modification times of
   the latters.  The format may be changed at any time without
   negative sideeffects (except re-test).]

One important side effect of c+d+f: one can now make

    test Bundle::Foo

over a giant bundle without being a superuser; then do

    sudo perl -MCPAN -wle 'install Bundle::Foo'

or

    sudo perl -MCPAN -wle 'install_tested'

[no tests are actually run with the second invocation; the first one
will retest things which were not successfully completed during `test
Bundle::Foo'.]

g) One can keep patches in the directory $CPANROOT/patches.  The
   patches should be named diff_$name; here $name is the name of the
   subdirectory of $CPANROOT/build/.  [I could not make the logic of
   saving the output of the patching step in a file - I need 2>&1, and
   I do not know how to produce this portably.]

h) New method ->containsdists() which works over all 3 kinds of
   objects.  [Unfortunately, it does not take into account
   dependencies of modules.  AFAIK, there is not such information
   stored in the CPAN index.  Maybe we should store it in a local
   database?]

Enjoy,
Ilya

--- ./lib/CPAN/FirstTime.pm-pre	Tue Jul 29 09:48:00 2003
+++ ./lib/CPAN/FirstTime.pm	Fri Oct 10 09:24:50 2003
@@ -168,7 +168,9 @@ with all the intermediate files\?
     $CPAN::Config->{build_cache} = $ans;
 
     # XXX This the time when we refetch the index files (in days)
-    $CPAN::Config->{'index_expire'} = 1;
+    $default = $CPAN::Config->{index_expire} || 1;
+    $ans = prompt("How often should be refetch the listings of CPAN contents (in days)?", $default);
+    $CPAN::Config->{index_expire} = $ans;
 
     print qq{
 
@@ -380,6 +382,45 @@ Your choice: ",$default);
 Typical frequently used setting:
 
     UNINST=1         to always uninstall potentially conflicting files
+
+Your choice: ",$default);
+
+    #
+    # Should we trust old builds?
+    #
+
+    $default = exists $CPAN::Config->{expire_old_builds} ?
+		exists $CPAN::Config->{expire_old_builds} : -1 ;
+    $CPAN::Config->{expire_old_builds} =
+	prompt("When should we expire old successfully tested builds?
+The value is in days; the value of -1 means 'never rebuild'; the value of 0
+means 'rebuild each time the distribution is tested'.
+
+Your choice: ",$default);
+
+    #
+    # Should we test uptodate modules etc?
+    #
+
+    $default = exists $CPAN::Config->{test_uptodate} ?
+		exists $CPAN::Config->{test_uptodate} : "modules bundles distributions" ;
+    $CPAN::Config->{test_uptodate} =
+	prompt("What kinds of test requests for uptodate modules, bundles, distributions
+should be granted?  The value is a combination of words 'modules', 'bundles',
+'distributions'.
+
+Your choice: ",$default);
+
+    #
+    # Should we install uptodate modules etc?
+    #
+
+    $default = exists $CPAN::Config->{install_uptodate} ?
+		exists $CPAN::Config->{install_uptodate} : "bundles distributions" ;
+    $CPAN::Config->{install_uptodate} =
+	prompt("What kinds of install requests for uptodate modules, bundles, distributions
+should be granted?  The value is a combination of words 'modules', 'bundles',
+'distributions'.
 
 Your choice: ",$default);
 
--- ./lib/CPAN.pm-pre	Thu Jul 31 13:56:22 2003
+++ ./lib/CPAN.pm	Fri Oct 10 09:54:02 2003
@@ -1,6 +1,7 @@
 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
 package CPAN;
-$VERSION = '1.76';
+$VERSION = '1.76_01';
+$VERSION = eval $VERSION;
 # $Id: CPAN.pm,v 1.412 2003/07/31 14:53:04 k Exp $
 
 # only used during development:
@@ -64,7 +65,7 @@ use vars qw($VERSION @EXPORT $AUTOLOAD $
 @CPAN::ISA = qw(CPAN::Debug Exporter);
 
 @EXPORT = qw(
-	     autobundle bundle expand force get cvs_import
+	     autobundle bundle expand force get cvs_import install_tested
 	     install make readme recompile shell test clean
 	    );
 
@@ -255,11 +256,11 @@ package CPAN::Complete;
 @CPAN::Complete::COMMANDS = sort qw(
 		       ! a b d h i m o q r u autobundle clean dump
 		       make test install force readme reload look
-                       cvs_import ls
+                       cvs_import ls install_tested
 ) unless @CPAN::Complete::COMMANDS;
 
 package CPAN::Index;
-use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
+use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $BUILD_DIRS);
 @CPAN::Index::ISA = qw(CPAN::Debug);
 $LAST_TIME ||= 0;
 $DATE_OF_03 ||= 0;
@@ -807,6 +808,10 @@ sub cleanup {
 	  $subroutine eq '(eval)';
   }
   return if $ineval && !$End;
+  if ($CPAN::Index::BUILD_DIRS and $CPAN::Index::BUILD_DIRS->{'*new*'}) {
+    CPAN::Index->write_metadata_cache();
+    $CPAN::Frontend->mywarn("List of tested dirs updated.\n");
+  }
   return unless defined $META->{LOCK};
   return unless -f $META->{LOCK};
   $META->savehist;
@@ -842,8 +847,9 @@ sub savehist {
     close $fh;
 }
 
+# Actually, this means: tested, but not installed...
 sub is_tested {
-    my($self,$what) = @_;
+    my($self,$what) = @_;
     $self->{is_tested}{$what} = 1;
 }
 
@@ -860,8 +866,14 @@ sub set_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");
+    my @dirs = map {("$_/blib/arch", "$_/blib/lib")} sort keys %{$self->{is_tested}};
+    if (@dirs < 15) {
+       $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
+    } else {
+       my @d = map {s/^\Q$CPAN::Config->{'build_dir'}/%BUILDDIR%/; $_ }
+	 sort keys %{$self->{is_tested}};
+       $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib subdirs of @d to PERL5LIB; %BUILDDIR%=$CPAN::Config->{'build_dir'}.\n");
+    }
     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
 }
 
@@ -1285,8 +1297,8 @@ sub missing_config_data {
          "pager",
          "makepl_arg", "make_arg", "make_install_arg", "urllist",
          "inhibit_startup_message", "ftp_proxy", "http_proxy", "no_proxy",
-         "prerequisites_policy",
-         "cache_metadata",
+         "prerequisites_policy", "expire_old_builds",
+         "cache_metadata", "test_uptodate", "install_uptodate"
         ) {
 	push @miss, $_ unless defined $CPAN::Config->{$_};
     }
@@ -1374,7 +1386,8 @@ Other
  h,?           display this menu       ! perl-code   eval a perl command
  o conf [opt]  set and query options   q             quit the cpan shell
  reload cpan   load CPAN.pm again      reload index  load newer indices
- autobundle    Snapshot                force cmd     unconditionally do cmd});
+ autobundle    Snapshot                force cmd     unconditionally do cmd
+ install_tested Only modules tested with this build of perl});
     }
 }
 
@@ -1493,13 +1506,14 @@ sub o {
 	    $CPAN::Frontend->myprint(":\n");
 	    for $k (sort keys %CPAN::Config::can) {
 		$v = $CPAN::Config::can{$k};
-		$CPAN::Frontend->myprint(sprintf "    %-18s %s\n", $k, $v);
+		# use distinctive whitespace to make the commands stand out
+		$CPAN::Frontend->myprint(sprintf "      %-10s %s\n", $k, $v);
 	    }
 	    $CPAN::Frontend->myprint("\n");
 	    for $k (sort keys %$CPAN::Config) {
                 CPAN::Config->prettyprint($k);
 	    }
-	    $CPAN::Frontend->myprint("\n");
+	    # $CPAN::Frontend->myprint("\n");	# Why second empty line?
 	} elsif (!CPAN::Config->edit(@o_what)) {
 	    $CPAN::Frontend->myprint(qq{Type 'o conf' to view configuration }.
                                      qq{edit options\n\n});
@@ -2046,6 +2060,39 @@ sub rematein {
     setup_output();
     CPAN->debug("pragma[$pragma]meth[$meth] some[@some]") if $CPAN::DEBUG;
 
+    if ($meth eq 'install_tested') {
+	$CPAN::Frontend->mywarn("install_tested() requires no arguments.\n"),
+	    return if @some;
+	CPAN::Index->reload;
+	@some = sort keys %$CPAN::Index::BUILD_DIRS if $CPAN::Index::BUILD_DIRS;
+	$CPAN::Frontend->mywarn("No tested distributions found.\n"),
+	    return unless @some;
+
+	$CPAN::Frontend->myprint("Checking which distributions were tested " .
+				 "with this version of perl...\n");
+	@some = grep CPAN::Shell->expandany($_)->persistent_tested_ok, @some;
+	$CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
+	    return unless @some;
+
+	$CPAN::Frontend->myprint("Looking for obsolete distributions...\n");
+	my ($dist, @process, %seen);
+	# as in CPAN::Distribution::cpntainsmods; but do one run only
+	for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
+	    my $mod_file = $mod->cpan_file or next;
+	    $seen{$mod_file}++;
+	}
+	for $dist (@some) {
+	    # my @mods = CPAN::Shell->expandany($dist)->containsmods;
+	    # The commented out check is meaningless; see containsmods().
+	    # @mods = grep CPAN::Shell->expandany($_)->cpan_file ne $dist, @mods;
+	    push(@process, $dist), next if $seen{$dist};
+	    $CPAN::Frontend->mywarn("$dist: all the modules are obsolete...\n");
+	}
+	@some = @process;
+	$CPAN::Frontend->mywarn("All the tested distributions are obsolete.\n"),
+		return unless @some;
+	$meth = 'install';
+    }
     # Here is the place to set "test_count" on all involved parties to
     # 0. We then can pass this counter on to the involved
     # distributions and those can refuse to test if test_count > X. In
@@ -2168,6 +2215,8 @@ sub clean   { shift->rematein('clean',@_
 sub look   { shift->rematein('look',@_); }
 #-> sub CPAN::Shell::cvs_import ;
 sub cvs_import   { shift->rematein('cvs_import',@_); }
+#-> sub CPAN::Shell::install_tested ;
+sub install_tested   { shift->rematein('install_tested',@_); }
 
 package CPAN::LWP::UserAgent;
 
@@ -2187,7 +2236,7 @@ sub get_basic_credentials {
     return unless $proxy;
     if ($USER && $PASSWD) {
     } elsif (defined $CPAN::Config->{proxy_user} &&
-        defined $CPAN::Config->{proxy_pass}) {
+             defined $CPAN::Config->{proxy_pass}) {
         $USER = $CPAN::Config->{proxy_user};
         $PASSWD = $CPAN::Config->{proxy_pass};
     } else {
@@ -3411,6 +3475,11 @@ sub write_metadata_cache {
     $cache->{last_time} = $LAST_TIME;
     $cache->{DATE_OF_02} = $DATE_OF_02;
     $cache->{PROTOCOL} = PROTOCOL;
+    if ($BUILD_DIRS) {
+	$cache->{'CPAN-sitearchexp'} = $Config::Config{sitearchexp};
+	delete $CPAN::Index::BUILD_DIRS->{'*new*'};
+        $cache->{'CPAN-tested-dirs'} = $BUILD_DIRS;
+    }
     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
     eval { Storable::nstore($cache, $metadata_file) };
     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
@@ -3471,6 +3540,12 @@ sub read_metadata_cache {
                             # does initialize to some protocol
     $LAST_TIME = $cache->{last_time};
     $DATE_OF_02 = $cache->{DATE_OF_02};
+    # Do not trust build directories of different version of Perl:
+    delete $cache->{'CPAN-tested-dirs'}
+	if exists $cache->{'CPAN-sitearchexp'}
+	    and $cache->{'CPAN-sitearchexp'} ne $Config::Config{sitearchexp};
+    $BUILD_DIRS = $cache->{'CPAN-tested-dirs'}
+	if exists $cache->{'CPAN-tested-dirs'};
     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
 	if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
     return;
@@ -3816,6 +3891,12 @@ sub called_for {
     return $self->{CALLED_FOR};
 }
 
+#-> sub CPAN::Distribution::containsdists
+sub containsdists {
+    my($self) = @_;
+    $self->{ID};
+}
+
 #-> sub CPAN::Distribution::safe_chdir ;
 sub safe_chdir {
     my($self,$todir) = @_;
@@ -3832,6 +3913,53 @@ sub safe_chdir {
     }
 }
 
+#-> sub CPAN::Distribution::patch ;
+sub patch {
+    my ($self, $name) = (@_);
+    return unless chdir $self->{build_dir};
+    my $dir = File::Spec->catdir($CPAN::Config->{'cpan_home'}, 'patches');
+    return unless -d $dir;
+    my $file = File::Spec->catfile($dir, "diff_$name");
+    my $gzip;
+    unless (-r $file) {
+	$gzip = $CPAN::Config->{gzip};
+	$file = File::Spec->catfile($dir, "diff_$name.gz");
+	unless (-r $file and $gzip) {
+	    $gzip = $CPAN::Config->{bzip2} || 'bzip2';
+	    $file = File::Spec->catfile($dir, "diff_$name.bz2");
+	    return unless -r $file;
+	}
+    }
+    $CPAN::Frontend->myprint("Found patch in `$file'");
+    my $patch = $Config::Config{gnupatch} || 'patch';
+    my $cmd = "$patch -p1";
+    if ($gzip) {
+	$cmd = "$gzip -dc $file | $cmd";
+    } else {
+	$cmd .= " <$file";
+    }
+    local *PATCH;
+    open PATCH, "$cmd |"
+      or $CPAN::Frontend->myprint("can't open pipe from `$cmd': $!") and return;
+    local *PATCHOUT;
+    my $out = 'cpan.patching';
+    open PATCHOUT, ">$out"
+      or $CPAN::Frontend->myprint("can't open $out: $!") and return;
+    my $old = select PATCHOUT;
+    $| = 1;
+    select $old;
+    while (<PATCH>) {
+	print PATCHOUT $_;
+	chomp;
+	$CPAN::Frontend->myprint($_);		# What to do if interactive?
+    }
+    close PATCHOUT
+      or $CPAN::Frontend->myprint("can't close $out: $!");
+    close PATCH
+      or $CPAN::Frontend->myprint("errors running `$cmd': rc=$?") and return;
+    $CPAN::Frontend->myprint("Patching from `$file' successful");
+}
+
 #-> sub CPAN::Distribution::get ;
 sub get {
     my($self) = @_;
@@ -3946,6 +4074,7 @@ sub get {
         my $pragmatic_dir = $userid . '000';
         $pragmatic_dir =~ s/\W_//g;
         $pragmatic_dir++ while -d "../$pragmatic_dir";
+	$distdir = $pragmatic_dir;
         $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
         $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
         File::Path::mkpath($packagedir);
@@ -4023,6 +4152,8 @@ WriteMakefile(NAME => q[$cf]);
             $fh->close;
         }
     }
+    $self->patch($distdir);
+    $self->safe_chdir($builddir);	# Back after patching
 
     return $self;
 }
@@ -4359,12 +4490,16 @@ sub force {
   if ($method && $method eq "install") {
     $self->{"force_update"}++; # name should probably have been force_install
   }
+  if ($method && $method eq "test") {
+    $self->{"force_test"}++; # name should probably have been force_install
+  }
 }
 
 #-> sub CPAN::Distribution::unforce ;
 sub unforce {
   my($self) = @_;
   delete $self->{'force_update'};
+  delete $self->{'force_test'};
 }
 
 #-> sub CPAN::Distribution::isa_perl ;
@@ -4492,6 +4627,8 @@ or
 	local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
 	my($ret,$pid);
 	$@ = "";
+	local $ENV{PERL5LIB} = $ENV{PERL5LIB} || $ENV{PERLLIB} || "";
+	$CPAN::META->set_perl5lib;
 	if ($CPAN::Config->{inactivity_timeout}) {
 	    eval {
 		alarm $CPAN::Config->{inactivity_timeout};
@@ -4541,12 +4678,15 @@ or
     }
     if ($CPAN::Signal){
       delete $self->{force_update};
+      delete $self->{force_test};
       return;
     }
-    if (my @prereq = $self->unsat_prereq){
+    if (my @prereq = $self->unsat_prereq('make')){
       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
     }
     $system = join " ", $CPAN::Config->{'make'}, $CPAN::Config->{make_arg};
+    local $ENV{PERL5LIB} = $ENV{PERL5LIB} || $ENV{PERLLIB} || "";
+    $CPAN::META->set_perl5lib;
     if (system($system) == 0) {
 	 $CPAN::Frontend->myprint("  $system -- OK\n");
 	 $self->{'make'} = "YES";
@@ -4595,13 +4735,14 @@ of modules we are processing right now?"
 
 #-> sub CPAN::Distribution::unsat_prereq ;
 sub unsat_prereq {
-    my($self) = @_;
+    my($self, $for) = @_;
     my $prereq_pm = $self->prereq_pm or return;
     my(@need);
   NEED: while (my($need_module, $need_version) = each %$prereq_pm) {
         my $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
         # we were too demanding:
         next if $nmo->uptodate;
+        next if $nmo->tested_ok and $for ne 'install';
 
         # if they have not specified a version, we accept any installed one
         if (not defined $need_version or
@@ -4682,16 +4823,111 @@ sub prereq_pm {
   return $self->{prereq_pm} = \%p;
 }
 
+#-> sub CPAN::Distribution::persistent_key ;
+sub persistent_key {	# Identify "sameness" of the Perl
+  my @keys = ($Config::Config{sitearchexp}, $^X);
+  push @keys, (-f $^X ? (stat(_))[9] : '--');	# mtime
+  my $dll = eval {OS2::DLLname()};
+  if (defined $dll) {
+    push @keys, $dll;
+    push @keys, (-f $dll ? (stat(_))[9] : '--');	# mtime
+  }
+  join "\n", @keys, '';
+}
+
+#-> sub CPAN::Distribution::persistent_tested_ok ;
+sub persistent_tested_ok {
+  my($self) = @_;
+  return unless $CPAN::Index::BUILD_DIRS and $CPAN::Config->{expire_old_builds};
+  my $dir = $CPAN::Index::BUILD_DIRS->{$self->id};
+  return unless $dir and -d $dir;
+  my $cpan_test_ok = File::Spec->catfile($dir, '.cpantok');
+  return unless -f $cpan_test_ok;
+  return if $CPAN::Config->{expire_old_builds} > 0
+	    and -M $cpan_test_ok > $CPAN::Config->{expire_old_builds};
+  {   local *T; local $/;
+      open T, $cpan_test_ok and <T> eq $self->persistent_key and close T
+	  or return;
+  }
+  my $date = -M $cpan_test_ok;
+  eval { File::Find::find sub {
+	  -M $_ >= $date
+	    or warn("File `$File::Find::name' newer than $cpan_test_ok: "
+		    . (-M _) . " days vs. $date days\n"),
+	       die 'update'
+	}, $dir ; 1} and return $dir;
+  warn "error scanning $dir: $@" unless $@ =~ /^update\b/;
+  return;
+}
+
+#-> sub CPAN::Distribution::mark_persistent_tested_ok ;
+sub mark_persistent_tested_ok {
+  my($self) = @_;
+  my $dir = $self->{build_dir};
+  return unless -d $dir;
+  my $cpan_test_ok = File::Spec->catfile($dir, '.cpantok');
+  local *T;
+  open T, "> $cpan_test_ok" or warn("error touching $cpan_test_ok: $!\n"), return;
+  print T $self->persistent_key;		# Something very build-specific
+  close T or warn("error touching $cpan_test_ok: $!\n"), return;
+  $CPAN::Index::BUILD_DIRS ||= {};
+  $CPAN::Index::BUILD_DIRS->{'*new*'} ||= 0;
+  $CPAN::Index::BUILD_DIRS->{'*new*'}++
+    unless exists $CPAN::Index::BUILD_DIRS->{$self->id}
+      and $CPAN::Index::BUILD_DIRS->{$self->id} eq $dir;
+  $CPAN::Index::BUILD_DIRS->{$self->id} = $dir;
+  return 1;
+}
+
+#-> sub CPAN::Distribution::tested_ok ;
+sub tested_ok {
+    my($self) = @_;
+    exists $self->{'make_test'} and $self->{'make_test'} ne 'NO'
+}
+
+#-> sub CPAN::Distribution::mark_tested_ok ;
+sub mark_tested_ok {
+    my($self) = @_;
+    $self->{make} = "YES";
+    $self->{make_test} = "YES";
+    my $c;
+    foreach $c ($self->containsmods) {
+        my $obj = CPAN::Shell->expandany($c);
+        $obj->mark_tested_ok();
+    }
+}
+
 #-> sub CPAN::Distribution::test ;
 sub test {
-    my($self) = @_;
+    my($self, $for) = @_;
+    if ($self->uptodate
+	and not $CPAN::Config->{test_uptodate} =~ /\bdistributions?\b/
+	and not exists $self->{'force_test'}
+	and not exists $self->{'force_update'}
+       ) {
+	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+	return;
+    }
+    my $tested_dir = $self->persistent_tested_ok;
+    if ($tested_dir and not $self->{'force_update'} and not $self->{'force_test'}) {
+	 $self->{'build_dir'} = $tested_dir;
+	 $CPAN::Frontend->myprint("Skipping test for " . $self->id . ": test was successful in $tested_dir\n");
+	 $CPAN::META->is_tested($self->{'build_dir'});
+	 $self->mark_tested_ok();
+	 chdir $self->{'build_dir'} or
+	    Carp::croak("Couldn't chdir to $self->{'build_dir'}");
+	 $self->debug("Changed directory to $self->{'build_dir'}")
+	    if $CPAN::DEBUG;
+	 return;
+    }
     $self->make;
     if ($CPAN::Signal){
       delete $self->{force_update};
+      delete $self->{force_test};
       return;
     }
     $CPAN::Frontend->myprint("Running make test\n");
-    if (my @prereq = $self->unsat_prereq){
+    if (my @prereq = $self->unsat_prereq($for or 'test')){
       return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
     }
   EXCUSE: {
@@ -4723,13 +4959,14 @@ sub test {
         return;
     }
 
-    local $ENV{PERL5LIB} = $ENV{PERL5LIB} || "";
+    local $ENV{PERL5LIB} = $ENV{PERL5LIB} || $ENV{PERLLIB} || "";
     $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";
+	 $self->mark_tested_ok();
+	 $self->mark_persistent_tested_ok();
     } else {
 	 $self->{make_test} = "NO";
          $self->{badtestcnt}++;
@@ -4769,6 +5006,7 @@ sub clean {
       # object's state back to where it is after untarring.
 
       delete $self->{force_update};
+      delete $self->{force_test};
       delete $self->{install};
       delete $self->{writemakefile};
       delete $self->{make};
@@ -4790,9 +5028,18 @@ make clean did not succeed, marking dire
 #-> sub CPAN::Distribution::install ;
 sub install {
     my($self) = @_;
-    $self->test;
+    if ($self->uptodate
+	and not $CPAN::Config->{install_uptodate} =~ /\bdistributions?\b/
+	and not exists $self->{'force_test'}
+	and not exists $self->{'force_update'}
+       ) {
+	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+	return;
+    }
+    $self->test('install');
     if ($CPAN::Signal){
       delete $self->{force_update};
+      delete $self->{force_test};
       return;
     }
     $CPAN::Frontend->myprint("Running make install\n");
@@ -4855,6 +5102,7 @@ sub install {
 	 }
     }
     delete $self->{force_update};
+    delete $self->{force_test};
 }
 
 #-> sub CPAN::Distribution::dir ;
@@ -4977,6 +5225,22 @@ Sorry for the inconvenience.
     @result;
 }
 
+#-> sub CPAN::Bundle::containsdists
+sub containsdists {
+    my($self) = @_;
+    my($elt, %dists);
+    for $elt ($self->contains) {
+	my $what = CPAN::Shell->expandany($elt);
+	$CPAN::Frontend->mywarn("$self->{ID}: $elt does not point anywhere\n"),
+	    next unless defined $what; 
+	my $dist;
+	for $dist ($what->containsdists) {
+	    $dists{$dist}++;
+	}
+    }
+    keys %dists;
+}
+
 #-> sub CPAN::Bundle::find_bundle_file
 sub find_bundle_file {
     my($self,$where,$what) = @_;
@@ -5102,6 +5366,8 @@ explicitly a file $s.
         }
     }
 
+    $self->mark_tested_ok() if $meth eq "test" and not %fail;
+
     # recap with less noise
     if ( $meth eq "install" ) {
 	if (%fail) {
@@ -5152,12 +5418,28 @@ sub make    { shift->rematein('make',@_)
 #-> sub CPAN::Bundle::test ;
 sub test    {
     my $self = shift;
+    if ($self->uptodate
+	and not $CPAN::Config->{test_uptodate} =~ /\bbundles?\b/
+	and not exists $self->{'force_test'}
+	and not exists $self->{'force_update'}
+       ) {
+	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+	return;
+    }
     $self->{badtestcnt} ||= 0;
     $self->rematein('test',@_);
 }
 #-> sub CPAN::Bundle::install ;
 sub install {
   my $self = shift;
+  if ($self->uptodate
+	and not $CPAN::Config->{install_uptodate} =~ /\bbundles?\b/
+	and not exists $self->{'force_test'}
+	and not exists $self->{'force_update'}
+       ) {
+	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+	return;
+  }
   $self->rematein('install',@_);
 }
 #-> sub CPAN::Bundle::clean ;
@@ -5170,11 +5452,25 @@ sub uptodate {
     my $c;
     foreach $c ($self->contains) {
         my $obj = CPAN::Shell->expandany($c);
-        return 0 unless $obj->uptodate;
+	# unrecognized stuff makes it not uptodate
+        return 0 unless defined $obj and $obj->uptodate;
     }
     return 1;
 }
 
+#-> sub CPAN::Bundle::mark_tested_ok ;
+sub mark_tested_ok {
+    my($self) = @_;
+    $self->{make_test_all} = "YES";
+}
+
+#-> sub CPAN::Module::tested_ok ;
+sub tested_ok {
+    my($self) = @_;
+    exists $self->{make_test_all} and $self->{make_test_all} eq "YES";
+}
+
+
 #-> sub CPAN::Bundle::readme ;
 sub readme  {
     my($self) = @_;
@@ -5427,7 +5723,7 @@ sub cpan_file {
                 }
                 return "Contact Author $fullname <$email>";
             } else {
-                return "UserID $userid";
+                return "Contact Author $userid (Email address not available)";
             }
         } else {
             return "N/A";
@@ -5435,6 +5731,12 @@ sub cpan_file {
     }
 }
 
+#-> sub CPAN::Module::containsdists
+sub containsdists {
+    my($self) = @_;
+    $self->cpan_file;
+}
+
 #-> sub CPAN::Module::cpan_version ;
 sub cpan_version {
     my $self = shift;
@@ -5452,6 +5754,7 @@ sub cpan_version {
 sub force {
     my($self) = @_;
     $self->{'force_update'}++;
+    $self->{'force_test'}++;
 }
 
 #-> sub CPAN::Module::rematein ;
@@ -5480,6 +5783,7 @@ sub rematein {
     $pack->$meth();
     $pack->unforce if $pack->can("unforce") && exists $self->{'force_update'};
     delete $self->{'force_update'};
+    delete $self->{'force_test'};
 }
 
 #-> sub CPAN::Module::readme ;
@@ -5499,7 +5803,15 @@ sub make   {
 sub test   {
     my $self = shift;
     $self->{badtestcnt} ||= 0;
-    $self->rematein('test',@_);
+    if ($self->uptodate
+	and not ($CPAN::Config->{test_uptodate} =~ /\bmodules?\b/)
+	and not exists $self->{'force_test'}
+	and not exists $self->{'force_update'}
+       ) {
+	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
+    } else {
+	$self->rematein('test',@_);
+    }
 }
 #-> sub CPAN::Module::uptodate ;
 sub uptodate {
@@ -5522,13 +5834,23 @@ sub uptodate {
     }
     return;
 }
+#-> sub CPAN::Module::mark_tested_ok ;
+sub mark_tested_ok {
+    my($self) = @_;
+    $self->{make_test_dist} = "YES";
+}
+#-> sub CPAN::Module::tested_ok ;
+sub tested_ok {
+    my($self) = @_;
+    exists $self->{make_test_dist} and $self->{make_test_dist} eq "YES";
+}
 #-> sub CPAN::Module::install ;
 sub install {
     my($self) = @_;
     my($doit) = 0;
     if ($self->uptodate
-	&&
-	not exists $self->{'force_update'}
+	and not $CPAN::Config->{install_uptodate} =~ /\bmodules?\b/
+	and not exists $self->{'force_update'}
        ) {
 	$CPAN::Frontend->myprint( $self->id. " is up to date.\n");
     } else {
@@ -5991,7 +6313,7 @@ Batch mode:
 
   use CPAN;
 
-  autobundle, clean, install, make, recompile, test
+  autobundle, clean, install, make, recompile, test, install_tested
 
 =head1 STATUS
 
@@ -6185,6 +6507,11 @@ perl breaks binary compatibility. If one
 is in turn depending on binary compatibility (so you cannot run CPAN
 commands), then you should try the CPAN::Nox module for recovery.
 
+=head2 install_tested()
+
+Installs all the modules successfully tested with this build of perl.
+[Currently works only with persistent index storage enabled.]
+
 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
 
 Although it may be considered internal, the class hierarchy does matter
@@ -6228,7 +6555,14 @@ CPAN::Module, the second by an object of
 
 If you do not enter the shell, the available shell commands are both
 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
-functions in the calling package (C<install(...)>).
+functions in the calling package (C<install(...)>).  Before calling low-level
+commands it makes sense to initialize components of CPAN you need, e.g.:
+
+  CPAN::Config->load;
+  CPAN::Index::setup_output;
+  CPAN::Index->reload;
+
+high-level commands do such initializations automatically.
 
 There's currently only one class that has a stable interface -
 CPAN::Shell. All commands that are available in the CPAN shell are
@@ -6751,6 +7085,9 @@ defined:
   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
+  expire_old_builds  Timeout in days; after this time the module is rebuild
+		     even if it was successfully build, and the build directory
+		     is still present.  -1 means 'never rebuild'.
   gzip		     location of external program gzip
   histfile           file to maintain history between sessions
   histsize           maximum number of lines to keep in histfile
@@ -6758,6 +7095,8 @@ defined:
                      many seconds inactivity. Set to 0 to never break.
   inhibit_startup_message
                      if true, does not print the startup message
+  install_uptodate   what (of modules/distributions/bundles) to install
+                     even if uptodate
   keep_source_where  directory in which to keep the source (if we do)
   make               location of external make program
   make_arg	     arguments that should always be passed to 'make'
@@ -6773,6 +7112,8 @@ defined:
   tar                location of external program tar
   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
                      (and nonsense for characters outside latin range)
+  test_uptodate      what (of modules/distributions/bundles) to test
+                     even if uptodate
   unzip              location of external program unzip
   urllist	     arrayref to nearby CPAN sites (or equivalent locations)
   wait_list          arrayref to a wait server to try (See CPAN::WAIT)

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About