Storable support, v-version fixes.
Andreas König [Tue, 22 Aug 2000 23:31:33 +0000 (01:31 +0200)]
Subject: CPAN.pm beta for testing available
Message-ID: <m3hf8dc79m.fsf@ak-71.mind.de>

p4raw-id: //depot/perl@6783

lib/CPAN.pm
lib/CPAN/FirstTime.pm

index 2d13335..6de43d3 100644 (file)
@@ -6,13 +6,13 @@ use vars qw{$Try_autoload
            $Frontend  $Defaultsite
           }; #};
 
-$VERSION = '1.57';
+$VERSION = '1.57_51';
 
-# $Id: CPAN.pm,v 1.305 2000/08/16 12:42:32 k Exp $
+# $Id: CPAN.pm,v 1.314 2000/08/21 12:37:43 k Exp $
 
 # only used during development:
 $Revision = "";
-# $Revision = "[".substr(q$Revision: 1.305 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.314 $, 10)."]";
 
 use Carp ();
 use Config ();
@@ -49,6 +49,7 @@ END { $End++; &cleanup; }
                  Eval           2048
                  Config         4096
                  Tarzip         8192
+                 Version       16384
 ];
 
 $CPAN::DEBUG ||= 0;
@@ -95,6 +96,8 @@ sub shell {
     $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) {
@@ -212,7 +215,6 @@ package CPAN::CacheMgr;
 use File::Find;
 
 package CPAN::Config;
-import ExtUtils::MakeMaker 'neatvalue';
 use vars qw(%can $dot_cpan);
 
 %can = (
@@ -986,13 +988,13 @@ package CPAN::Config;
 #-> 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]") if $CPAN::DEBUG;
@@ -1021,12 +1023,7 @@ sub edit {
                $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
@@ -1036,13 +1033,38 @@ sub edit {
             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) = @_;
@@ -1204,6 +1226,7 @@ sub not_loaded {
            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
           )) {
        push @miss, $_ unless defined $CPAN::Config->{$_};
     }
@@ -1352,13 +1375,16 @@ sub i {
 }
 
 #-> 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'}) {
@@ -1374,22 +1400,7 @@ sub o {
            }
            $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)) {
@@ -1546,22 +1557,22 @@ sub _u_r_common {
     for $module ($self->expand('Module',@args)) {
        my $file  = $module->cpan_file;
        next unless defined $file; # ??
-       my($latest) = $module->cpan_version; # %vd
+       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; # %vd
+               $have = $module->inst_version; # %vd already applied
            } elsif ($what eq "r") {
-               $have = $module->inst_version; # %vd
+               $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
@@ -1599,21 +1610,14 @@ sub _u_r_common {
                   "in CPAN file"
                   ));
        }
-        for ($have,$latest) {
-          if ($] >= 5.006) { # people start using v-strings
-            local($^W) = 0;
-            unless (/^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
-                    && "$2$4" ne ""
-                    ||
-                    /^undef$/
-                    ||
-                    /^-$/ # not installed
-                   ) {
-              $_ = sprintf "%vd", $_;
-            }
-          }
-          $_ = substr($_,0,8) if length($_) > 8;
-        }
+####        for ($have,$latest) {
+####          # $_ = CPAN::Version->readable($_); # %vd already applied
+####          if (length($_) > 8){
+####            my $trunc = substr($_,0,8);
+####            $CPAN::Frontend->mywarn("Truncating VERSION from [$_] to [$trunc]\n");
+####            $_ = $trunc;
+####          }
+####        }
        $CPAN::Frontend->myprint(sprintf $sprintf,
                                  $module->id,
                                  $have,
@@ -2792,6 +2796,7 @@ sub reload {
                               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;
@@ -2949,11 +2954,13 @@ $index_target, $line_count, scalar(@lines);
            $id = $CPAN::META->instance('CPAN::Module',$mod);
        }
 
-       if ($id->cpan_file ne $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, # %vd
+                    'CPAN_VERSION' => $version, # %vd not needed
                     'CPAN_FILE' => $dist,
                      'CPAN_COMMENT' => $comment,
                    );
@@ -3018,6 +3025,42 @@ sub 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::store($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::/;
+       $CPAN::META->{$k} = $v;
+    }
+    $last_time = $cache->{last_time};
+}
+
 package CPAN::InfoObj;
 
 #-> sub CPAN::InfoObj::new ;
@@ -3168,6 +3211,7 @@ sub get {
        CPAN::FTP->localize("authors/id/$self->{ID}", $local_wanted)
            or $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n");
     $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: $!");
@@ -3317,7 +3361,7 @@ sub pm2dir_me {
 sub new {
     my($class,%att) = @_;
 
-    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+    # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
 
     my $this = { %att };
     return bless $this, $class;
@@ -3363,7 +3407,7 @@ sub cvs_import {
 
     my $package = $self->called_for;
     my $module = $CPAN::META->instance('CPAN::Module', $package);
-    my $version = $module->cpan_version; # %vd
+    my $version = $module->cpan_version; # %vd not needed
 
     my $userid = $self->{CPAN_USERID};
 
@@ -3652,7 +3696,7 @@ or
                               $CPAN::META->instance(
                                                     'CPAN::Module',
                                                     $self->called_for
-                                                   )->cpan_version, # %vd
+                                                   )->cpan_version, # %vd not needed
                               $self->called_for,
                               $self->isa_perl,
                               $self->called_for,
@@ -3829,10 +3873,14 @@ sub needs_prereq {
     # check, because if 'force' is in effect, nobody else will check.
     {
       local($^W) = 0;
-      if (defined $mo->inst_file &&
-          $mo->inst_version >= $need_version){ # %vd
+      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;
       }
@@ -3987,7 +4035,8 @@ package CPAN::Bundle;
 sub as_string {
     my($self) = @_;
     $self->contains;
-    $self->{INST_VERSION} ||= $self->inst_version; # %vd
+    # 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;
 }
 
@@ -4268,8 +4317,8 @@ sub as_string {
                          );
        }
     }
-    push @m, sprintf($sprintf, 'CPAN_VERSION', $self->{CPAN_VERSION}) # %vd
-       if $self->{CPAN_VERSION}; # %vd
+    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";
@@ -4309,7 +4358,7 @@ sub as_string {
     push @m, sprintf($sprintf, 'INST_FILE',
                     $local_file || "(not installed)");
     push @m, sprintf($sprintf, 'INST_VERSION',
-                    $self->inst_version) if $local_file; #%vd
+                    $self->inst_version) if $local_file; #%vd already applied
     join "", @m, "\n";
 }
 
@@ -4378,7 +4427,7 @@ sub cpan_version {
                                                 # and do not want to
                                                 # provoke too many
                                                 # bugreports
-    $self->{'CPAN_VERSION'}; # %vd
+    $self->{'CPAN_VERSION'}; # %vd not needed
 }
 
 #-> sub CPAN::Module::force ;
@@ -4427,17 +4476,17 @@ sub test   { shift->rematein('test') }
 #-> sub CPAN::Module::uptodate ;
 sub uptodate {
     my($self) = @_;
-    my($latest) = $self->cpan_version; # %vd
+    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; # %vd?
+       $have = $self->inst_version; # %vd already applied
     }
     local($^W)=0;
     if ($inst_file
        &&
-       $have >= $latest # %vd
+       ! CPAN::Version->vgt($latest, $have)
        ) {
       return 1;
     }
@@ -4496,7 +4545,6 @@ sub inst_version {
     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]"; };
 
@@ -4513,19 +4561,26 @@ sub inst_version {
 
     # local($SIG{__WARN__}) =  sub { warn "2. have[$have]"; };
 
-    if ($] >= 5.006) { # people start using v-strings
-      unless ($have =~ /^([+-]?)([\d_]*)(\.([\d_]*))?([Ee]([+-]?[\d_]+))?$/
-              && "$2$4" ne ""
-              ||
-              /^undef$/
-              ||
-              /^-$/
-             ) {
-        $have = sprintf "%vd", $have;
-      }
-    }
+    # Should %vd hack happen here? Must we not maintain the original
+    # version string until it is used? Do we for printing make it
+    # human readable? Or do we maintain it in a human readable form?
+    # "v1.0.2"?
+
+    # OK, let's discuss the pros and cons:
+    #-maintain it as string with leading v:
+    # read index files     do nothing
+    # compare it           use utility for compare
+    # print it             do nothing
+
+    # 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"
+
+    $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
 }
 
@@ -4728,6 +4783,45 @@ sub unzip {
   return 1;
 }
 
+package CPAN::Version;
+
+sub vgt {
+  my($self,$l,$r) = @_;
+  local($^W) = 0;
+  CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
+  return 1 if $r eq "undef" && $l ne "undef";
+  return if $l eq "undef" && $r ne "undef";
+  return 1 if $] >= 5.006 && $l =~ /^v/ && $r =~ /^v/ &&
+      $self->vstring($l) gt $self->vstring($r);
+  return 1 if $l > $r;
+  return 1 if $l gt $r;
+  return;
+}
+
+sub vstring {
+  my($self,$n) = @_;
+  $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid argument [$n]";
+  pack "U*", split /\./, $n;
+}
+
+sub readable {
+  my($self,$n) = @_;
+  return $n if $n =~ /^[\w\-\+\.]+$/;
+  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;
@@ -5176,6 +5270,7 @@ defined:
   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
index 9bd12f3..cd2c49d 100644 (file)
@@ -16,7 +16,7 @@ use FileHandle ();
 use File::Basename ();
 use File::Path ();
 use vars qw($VERSION);
-$VERSION = substr q$Revision: 1.40 $, 10;
+$VERSION = substr q$Revision: 1.41 $, 10;
 
 =head1 NAME
 
@@ -174,6 +174,20 @@ disable the cache scanning with 'never'.
     } while ($ans ne 'atstart' && $ans ne 'never');
     $CPAN::Config->{scan_cache} = $ans;
 
+    print qq{
+
+To speed up the initial CPAN shell startup, it is possible to use
+Storable or FreezeThaw to create an cache of metadata. If no
+serializer is avaiable, the normal index mechanism will be used.
+
+};
+
+    defined($default = $CPAN::Config->{cache_metadata}) or $default = 1;
+    do {
+        $ans = prompt("Cache metadata (yes/no)?", ($default ? 'yes' : 'no'));
+    } while ($ans !~ /^\s*[yn]/i);
+    $CPAN::Config->{cache_metadata} = ($ans =~ /^\s*y/i ? 1 : 0);
+
     #
     # prerequisites_policy
     # Do we follow PREREQ_PM?