[perl5.git] / lib / CPAN / Index.pm

package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
$VERSION = "1.93";
@CPAN::Index::ISA = qw(CPAN::Debug);
$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 }

#-> sub CPAN::Index::force_reload ;
sub force_reload {
    my($class) = @_;
    $CPAN::Index::LAST_TIME = 0;
    $class->reload(1);
}

my @indexbundle =
    (
     {
      reader => "rd_authindex",
      dir => "authors",
      remotefile => '01mailrc.txt.gz',
      shortlocalfile => '01mailrc.gz',
     },
     {
      reader => "rd_modpacks",
      dir => "modules",
      remotefile => '02packages.details.txt.gz',
      shortlocalfile => '02packag.gz',
     },
     {
      reader => "rd_modlist",
      dir => "modules",
      remotefile => '03modlist.data.gz',
      shortlocalfile => '03mlist.gz',
     },
    );

#-> sub CPAN::Index::reload ;
sub reload {
    my($self,$force) = @_;
    my $time = time;

    # XXX check if a newer one is available. (We currently read it
    # from time to time)
    for ($CPAN::Config->{index_expire}) {
        $_ = 0.001 unless $_ && $_ > 0.001;
    }
    unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
        # debug here when CPAN doesn't seem to read the Metadata
        require Carp;
        Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
    }
    unless ($CPAN::META->{PROTOCOL}) {
        $self->read_metadata_cache;
        $CPAN::META->{PROTOCOL} ||= "1.0";
    }
    if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
        # warn "Setting last_time to 0";
        $LAST_TIME = 0; # No warning necessary
    }
    if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
        and ! $force) {
        # called too often
        # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
    } elsif (0) {
        # IFF we are developing, it helps to wipe out the memory
        # between reloads, otherwise it is not what a user expects.
        undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
        $CPAN::META = CPAN->new;
    } else {
        my($debug,$t2);
        local $LAST_TIME = $time;
        local $CPAN::META->{PROTOCOL} = PROTOCOL;

        my $needshort = $^O eq "dos";

    INX: for my $indexbundle (@indexbundle) {
            my $reader = $indexbundle->{reader};
            my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
            my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
            my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
            my $localized = $self->reload_x($remote, $localpath, $force);
            $self->$reader($localized); # may die but we let the shell catch it
            if ($CPAN::DEBUG){
                $t2 = time;
                $debug = "timing reading 01[".($t2 - $time)."]";
                $time = $t2;
            }
            return if $CPAN::Signal; # this is sometimes lengthy
        }
        $self->write_metadata_cache;
        if ($CPAN::DEBUG){
            $t2 = time;
            $debug .= "03[".($t2 - $time)."]";
            $time = $t2;
        }
        CPAN->debug($debug) if $CPAN::DEBUG;
    }
    if ($CPAN::Config->{build_dir_reuse}) {
        $self->reanimate_build_dir;
    }
    if (CPAN::_sqlite_running()) {
        $CPAN::SQLite->reload(time => $time, force => $force)
            if not $LAST_TIME;
    }
    $LAST_TIME = $time;
    $CPAN::META->{PROTOCOL} = PROTOCOL;
}

#-> sub CPAN::Index::reanimate_build_dir ;
sub reanimate_build_dir {
    my($self) = @_;
    unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
        return;
    }
    return if $HAVE_REANIMATED++;
    my $d = $CPAN::Config->{build_dir};
    my $dh = DirHandle->new;
    opendir $dh, $d or return; # does not exist
    my $dirent;
    my $i = 0;
    my $painted = 0;
    my $restored = 0;
    my @candidates = map { $_->[0] }
        sort { $b->[1] <=> $a->[1] }
            map { [ $_, -M File::Spec->catfile($d,$_) ] }
                grep {/\.yml$/} readdir $dh;
    unless (@candidates) {
        $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
        return;
    }
    $CPAN::Frontend->myprint
        (sprintf("Going to read %d yaml file%s from %s/\n",
                 scalar @candidates,
                 @candidates==1 ? "" : "s",
                 $CPAN::Config->{build_dir}
                ));
    my $start = CPAN::FTP::_mytime();
  DISTRO: for $i (0..$#candidates) {
        my $dirent = $candidates[$i];
        my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
        if ($@) {
            warn "Error while parsing file '$dirent'; error: '$@'";
            next DISTRO;
        }
        my $c = $y->[0];
        if ($c && CPAN->_perl_fingerprint($c->{perl})) {
            my $key = $c->{distribution}{ID};
            for my $k (keys %{$c->{distribution}}) {
                if ($c->{distribution}{$k}
                    && ref $c->{distribution}{$k}
                    && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
                    $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
                }
            }

            #we tried to restore only if element already
            #exists; but then we do not work with metadata
            #turned off.
            my $do
                = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
                    = $c->{distribution};
            for my $skipper (qw(
                                badtestcnt
                                configure_requires_later
                                configure_requires_later_for
                                force_update
                                later
                                later_for
                                notest
                                should_report
                                sponsored_mods
                                prefs
                                negative_prefs_cache
                               )) {
                delete $do->{$skipper};
            }
            if ($do->tested_ok_but_not_installed) {
                $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
            }
            $restored++;
        }
        $i++;
        while (($painted/76) < ($i/@candidates)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
    }
    my $took = CPAN::FTP::_mytime() - $start;
    $CPAN::Frontend->myprint(sprintf(
                                     "DONE\nRestored the state of %s (in %.4f secs)\n",
                                     $restored || "none",
                                     $took,
                                    ));
}


#-> sub CPAN::Index::reload_x ;
sub reload_x {
    my($cl,$wanted,$localname,$force) = @_;
    $force |= 2; # means we're dealing with an index here
    CPAN::HandleConfig->load; # we should guarantee loading wherever
                              # we rely on Config XXX
    $localname ||= $wanted;
    my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
                                         $localname);
    if (
        -f $abs_wanted &&
        -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
        !($force & 1)
       ) {
        my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
        $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
                   qq{day$s. I\'ll use that.});
        return $abs_wanted;
    } else {
        $force |= 1; # means we're quite serious about it.
    }
    return CPAN::FTP->localize($wanted,$abs_wanted,$force);
}

#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
    my($cl, $index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    my @lines;
    $CPAN::Frontend->myprint("Going to read '$index_target'\n");
    local(*FH);
    tie *FH, 'CPAN::Tarzip', $index_target;
    local($/) = "\n";
    local($_);
    push @lines, split /\012/ while <FH>;
    my $i = 0;
    my $painted = 0;
    foreach (@lines) {
        my($userid,$fullname,$email) =
            m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
        $fullname ||= $email;
        if ($userid && $fullname && $email) {
            my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
            $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
        } else {
            CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
        }
        $i++;
        while (($painted/76) < ($i/@lines)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
}

sub userid {
  my($self,$dist) = @_;
  $dist = $self->{'id'} unless defined $dist;
  my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
  $ret;
}

#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
    my($self, $index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    $CPAN::Frontend->myprint("Going to read '$index_target'\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    local $_;
    CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
    my $slurp = "";
    my $chunk;
    while (my $bytes = $fh->READ(\$chunk,8192)) {
        $slurp.=$chunk;
    }
    my @lines = split /\012/, $slurp;
    CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
    undef $fh;
    # read header
    my($line_count,$last_updated);
    while (@lines) {
        my $shift = shift(@lines);
        last if $shift =~ /^\s*$/;
        $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
        $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
    }
    CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
    if (not defined $line_count) {

        $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count 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
});

        $CPAN::Frontend->mysleep(5);
    } elsif ($line_count != scalar @lines) {

        $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. 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\n},
$index_target, $line_count, scalar(@lines));

    }
    if (not defined $last_updated) {

        $CPAN::Frontend->mywarn(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
});

        $CPAN::Frontend->mysleep(5);
    } else {

        $CPAN::Frontend
            ->myprint(sprintf qq{  Database was generated on %s\n},
                      $last_updated);
        $DATE_OF_02 = $last_updated;

        my $age = time;
        if ($CPAN::META->has_inst('HTTP::Date')) {
            require HTTP::Date;
            $age -= HTTP::Date::str2time($last_updated);
        } else {
            $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
            require Time::Local;
            my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
            $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
            $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
        }
        $age /= 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);

        } elsif ($age < -1) {

            $CPAN::Frontend
                ->mywarn(sprintf
                         qq{Warning: Your system date is %d days behind this index file!
  System time:          %s
  Timestamp index file: %s
  Please fix your system time, problems with the make command expected.\n},
                         -$age,
                         scalar gmtime,
                         $DATE_OF_02,
                        );

        }
    }


    # A necessity since we have metadata_cache: delete what isn't
    # there anymore
    my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
    CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
    my(%exists);
    my $i = 0;
    my $painted = 0;
    foreach (@lines) {
        # before 1.56 we split into 3 and discarded the rest. From
        # 1.57 we assign remaining text to $comment thus allowing to
        # influence isa_perl
        my($mod,$version,$dist,$comment) = split " ", $_, 4;
        unless ($mod && defined $version && $dist) {
            $CPAN::Frontend->mywarn("Could not split line[$_]\n");
            next;
        }
        my($bundle,$id,$userid);

        if ($mod eq 'CPAN' &&
            ! (
            CPAN::Queue->exists('Bundle::CPAN') ||
            CPAN::Queue->exists('CPAN')
            )
        ) {
            local($^W)= 0;
            if ($version > $CPAN::VERSION) {
                $CPAN::Frontend->mywarn(qq{
  New CPAN.pm version (v$version) available.
  [Currently running version is v$CPAN::VERSION]
  You might want to try
    install CPAN
    reload cpan
  to both upgrade CPAN.pm and run the new version without leaving
  the current session.

}); #});
                $CPAN::Frontend->mysleep(2);
                $CPAN::Frontend->myprint(qq{\n});
            }
            last if $CPAN::Signal;
        } elsif ($mod =~ /^Bundle::(.*)/) {
            $bundle = $1;
        }

        if ($bundle) {
            $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
            # Let's make it a module too, because bundles have so much
            # in common with modules.

            # Changed in 1.57_63: seems like memory bloat now without
            # any value, so commented out

            # $CPAN::META->instance('CPAN::Module',$mod);

        } else {

            # instantiate a module object
            $id = $CPAN::META->instance('CPAN::Module',$mod);

        }

        # Although CPAN prohibits same name with different version the
        # indexer may have changed the version for the same distro
        # since the last time ("Force Reindexing" feature)
        if ($id->cpan_file ne $dist
            ||
            $id->cpan_version ne $version
           ) {
            $userid = $id->userid || $self->userid($dist);
            $id->set(
                     'CPAN_USERID' => $userid,
                     'CPAN_VERSION' => $version,
                     'CPAN_FILE' => $dist,
                    );
        }

        # instantiate a distribution object
        if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
        # we do not need CONTAINSMODS unless we do something with
        # this dist, so we better produce it on demand.

        ## my $obj = $CPAN::META->instance(
        ##                                 'CPAN::Distribution' => $dist
        ##                                );
        ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
        } else {
            $CPAN::META->instance(
                                  'CPAN::Distribution' => $dist
                                 )->set(
                                        'CPAN_USERID' => $userid,
                                        'CPAN_COMMENT' => $comment,
                                       );
        }
        if ($secondtime) {
            for my $name ($mod,$dist) {
                # $self->debug("exists name[$name]") if $CPAN::DEBUG;
                $exists{$name} = undef;
            }
        }
        $i++;
        while (($painted/76) < ($i/@lines)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
    if ($secondtime) {
        for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
            for my $o ($CPAN::META->all_objects($class)) {
                next if exists $exists{$o->{ID}};
                $CPAN::META->delete($class,$o->{ID});
                # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
                #     if $CPAN::DEBUG;
            }
        }
    }
}

#-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
    my($cl,$index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    $CPAN::Frontend->myprint("Going to read '$index_target'\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    local $_;
    my $slurp = "";
    my $chunk;
    while (my $bytes = $fh->READ(\$chunk,8192)) {
        $slurp.=$chunk;
    }
    my @eval2 = split /\012/, $slurp;

    while (@eval2) {
        my $shift = shift(@eval2);
        if ($shift =~ /^Date:\s+(.*)/) {
            if ($DATE_OF_03 eq $1) {
                $CPAN::Frontend->myprint("Unchanged.\n");
                return;
            }
            ($DATE_OF_03) = $1;
        }
        last if $shift =~ /^\s*$/;
    }
    push @eval2, q{CPAN::Modulelist->data;};
    local($^W) = 0;
    my($compmt) = Safe->new("CPAN::Safe1");
    my($eval2) = join("\n", @eval2);
    CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
    my $ret = $compmt->reval($eval2);
    Carp::confess($@) if $@;
    return if $CPAN::Signal;
    my $i = 0;
    my $until = keys(%$ret);
    my $painted = 0;
    CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
    for (keys %$ret) {
        my $obj = $CPAN::META->instance("CPAN::Module",$_);
        delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
        $obj->set(%{$ret->{$_}});
        $i++;
        while (($painted/76) < ($i/$until)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
}

#-> sub CPAN::Index::write_metadata_cache ;
sub write_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return if CPAN::_sqlite_running();
    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->{readonly}{$k}; # unsafe meta access, ok
    }
    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
    $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) };
    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}

#-> sub CPAN::Index::read_metadata_cache ;
sub read_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return if CPAN::_sqlite_running();
    return unless $CPAN::META->has_usable("Storable");
    my $metadata_file = File::Spec->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 $@; # ?? missing "\n" after $@ in mywarn ??
    if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
        $LAST_TIME = 0;
        return;
    }
    if (exists $cache->{PROTOCOL}) {
        if (PROTOCOL > $cache->{PROTOCOL}) {
            $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
                                            "with protocol v%s, requiring v%s\n",
                                            $cache->{PROTOCOL},
                                            PROTOCOL)
                                   );
            return;
        }
    } else {
        $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
                                "with protocol v1.0\n");
        return;
    }
    my $clcnt = 0;
    my $idcnt = 0;
    while(my($class,$v) = each %$cache) {
        next unless $class =~ /^CPAN::/;
        $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
        while (my($id,$ro) = each %$v) {
            $CPAN::META->{readwrite}{$class}{$id} ||=
                $class->new(ID=>$id, RO=>$ro);
            $idcnt++;
        }
        $clcnt++;
    }
    unless ($clcnt) { # sanity check
        $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
        return;
    }
    if ($idcnt < 1000) {
        $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
                                 "in $metadata_file\n");
        return;
    }
    $CPAN::META->{PROTOCOL} ||=
        $cache->{PROTOCOL}; # reading does not up or downgrade, but it
                            # does initialize to some protocol
    $LAST_TIME = $cache->{last_time};
    $DATE_OF_02 = $cache->{DATE_OF_02};
    $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;
}

1;
Commit	Line	Data
f9916dde A	1	package CPAN::Index;
	2	use strict;
	3	use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
	4	$VERSION = "1.93";
	5	@CPAN::Index::ISA = qw(CPAN::Debug);
	6	$LAST_TIME \|\|= 0;
	7	$DATE_OF_03 \|\|= 0;
	8	# use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
	9	sub PROTOCOL { 2.0 }
	10
	11	#-> sub CPAN::Index::force_reload ;
	12	sub force_reload {
	13	my($class) = @_;
	14	$CPAN::Index::LAST_TIME = 0;
	15	$class->reload(1);
	16	}
	17
2f2071b1 A	18	my @indexbundle =
	19	(
	20	{
	21	reader => "rd_authindex",
	22	dir => "authors",
	23	remotefile => '01mailrc.txt.gz',
	24	shortlocalfile => '01mailrc.gz',
	25	},
	26	{
	27	reader => "rd_modpacks",
	28	dir => "modules",
	29	remotefile => '02packages.details.txt.gz',
	30	shortlocalfile => '02packag.gz',
	31	},
	32	{
	33	reader => "rd_modlist",
	34	dir => "modules",
	35	remotefile => '03modlist.data.gz',
	36	shortlocalfile => '03mlist.gz',
	37	},
	38	);
	39
f9916dde A	40	#-> sub CPAN::Index::reload ;
	41	sub reload {
	42	my($self,$force) = @_;
	43	my $time = time;
	44
	45	# XXX check if a newer one is available. (We currently read it
	46	# from time to time)
	47	for ($CPAN::Config->{index_expire}) {
	48	$_ = 0.001 unless $_ && $_ > 0.001;
	49	}
	50	unless (1 \|\| $CPAN::Have_warned->{readmetadatacache}++) {
	51	# debug here when CPAN doesn't seem to read the Metadata
	52	require Carp;
	53	Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
	54	}
	55	unless ($CPAN::META->{PROTOCOL}) {
	56	$self->read_metadata_cache;
	57	$CPAN::META->{PROTOCOL} \|\|= "1.0";
	58	}
	59	if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
	60	# warn "Setting last_time to 0";
	61	$LAST_TIME = 0; # No warning necessary
	62	}
	63	if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
	64	and ! $force) {
	65	# called too often
	66	# CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
	67	} elsif (0) {
	68	# IFF we are developing, it helps to wipe out the memory
	69	# between reloads, otherwise it is not what a user expects.
	70	undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
	71	$CPAN::META = CPAN->new;
	72	} else {
	73	my($debug,$t2);
	74	local $LAST_TIME = $time;
	75	local $CPAN::META->{PROTOCOL} = PROTOCOL;
	76
	77	my $needshort = $^O eq "dos";
	78
2f2071b1 A	79	INX: for my $indexbundle (@indexbundle) {
	80	my $reader = $indexbundle->{reader};
	81	my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
	82	my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
	83	my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
	84	my $localized = $self->reload_x($remote, $localpath, $force);
	85	$self->$reader($localized); # may die but we let the shell catch it
	86	if ($CPAN::DEBUG){
	87	$t2 = time;
	88	$debug = "timing reading 01[".($t2 - $time)."]";
	89	$time = $t2;
	90	}
	91	return if $CPAN::Signal; # this is sometimes lengthy
	92	}
f9916dde	93	$self->write_metadata_cache;
2f2071b1 A	94	if ($CPAN::DEBUG){
	95	$t2 = time;
	96	$debug .= "03[".($t2 - $time)."]";
	97	$time = $t2;
	98	}
f9916dde A	99	CPAN->debug($debug) if $CPAN::DEBUG;
	100	}
	101	if ($CPAN::Config->{build_dir_reuse}) {
	102	$self->reanimate_build_dir;
	103	}
	104	if (CPAN::_sqlite_running()) {
	105	$CPAN::SQLite->reload(time => $time, force => $force)
	106	if not $LAST_TIME;
	107	}
	108	$LAST_TIME = $time;
	109	$CPAN::META->{PROTOCOL} = PROTOCOL;
	110	}
	111
	112	#-> sub CPAN::Index::reanimate_build_dir ;
	113	sub reanimate_build_dir {
	114	my($self) = @_;
	115	unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}\|\|"YAML")) {
	116	return;
	117	}
	118	return if $HAVE_REANIMATED++;
	119	my $d = $CPAN::Config->{build_dir};
	120	my $dh = DirHandle->new;
	121	opendir $dh, $d or return; # does not exist
	122	my $dirent;
	123	my $i = 0;
	124	my $painted = 0;
	125	my $restored = 0;
	126	my @candidates = map { $_->[0] }
	127	sort { $b->[1] <=> $a->[1] }
	128	map { [ $_, -M File::Spec->catfile($d,$_) ] }
	129	grep {/\.yml$/} readdir $dh;
	130	unless (@candidates) {
	131	$CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
	132	return;
	133	}
	134	$CPAN::Frontend->myprint
	135	(sprintf("Going to read %d yaml file%s from %s/\n",
	136	scalar @candidates,
	137	@candidates==1 ? "" : "s",
	138	$CPAN::Config->{build_dir}
	139	));
	140	my $start = CPAN::FTP::_mytime();
	141	DISTRO: for $i (0..$#candidates) {
	142	my $dirent = $candidates[$i];
	143	my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
	144	if ($@) {
	145	warn "Error while parsing file '$dirent'; error: '$@'";
	146	next DISTRO;
	147	}
	148	my $c = $y->[0];
	149	if ($c && CPAN->_perl_fingerprint($c->{perl})) {
	150	my $key = $c->{distribution}{ID};
	151	for my $k (keys %{$c->{distribution}}) {
	152	if ($c->{distribution}{$k}
	153	&& ref $c->{distribution}{$k}
	154	&& UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
	155	$c->{distribution}{$k}{COMMANDID} = $i - @candidates;
	156	}
	157	}
	158
	159	#we tried to restore only if element already
	160	#exists; but then we do not work with metadata
	161	#turned off.
	162	my $do
163	= $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
164	= $c->{distribution};
165	for my $skipper (qw(
166	badtestcnt
167	configure_requires_later
168	configure_requires_later_for
169	force_update
170	later
171	later_for
172	notest
173	should_report
174	sponsored_mods
175	prefs
176	negative_prefs_cache
177	)) {
178	delete $do->{$skipper};
179	}
180	if ($do->tested_ok_but_not_installed) {
181	$CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
182	}
183	$restored++;
184	}
185	$i++;
186	while (($painted/76) < ($i/@candidates)) {
187	$CPAN::Frontend->myprint(".");
188	$painted++;
189	}
190	}
191	my $took = CPAN::FTP::_mytime() - $start;
192	$CPAN::Frontend->myprint(sprintf(
193	"DONE\nRestored the state of %s (in %.4f secs)\n",
194	$restored \|\| "none",
195	$took,
196	));
197	}
198
199
200	#-> sub CPAN::Index::reload_x ;
201	sub reload_x {
202	my($cl,$wanted,$localname,$force) = @_;
203	$force \|= 2; # means we're dealing with an index here
204	CPAN::HandleConfig->load; # we should guarantee loading wherever
205	# we rely on Config XXX
206	$localname \|\|= $wanted;
207	my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
208	$localname);
209	if (
210	-f $abs_wanted &&
211	-M $abs_wanted < $CPAN::Config->{'index_expire'} &&
212	!($force & 1)
213	) {
214	my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
215	$cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
216	qq{day$s. I\'ll use that.});
217	return $abs_wanted;
218	} else {
219	$force \|= 1; # means we're quite serious about it.
220	}
221	return CPAN::FTP->localize($wanted,$abs_wanted,$force);
222	}
223
224	#-> sub CPAN::Index::rd_authindex ;
225	sub rd_authindex {
226	my($cl, $index_target) = @_;
227	return unless defined $index_target;
228	return if CPAN::_sqlite_running();
229	my @lines;
230	$CPAN::Frontend->myprint("Going to read '$index_target'\n");
231	local(*FH);
232	tie *FH, 'CPAN::Tarzip', $index_target;
233	local($/) = "\n";
234	local($_);
235	push @lines, split /\012/ while <FH>;
236	my $i = 0;
237	my $painted = 0;
238	foreach (@lines) {
239	my($userid,$fullname,$email) =
240	m/alias\s+(\S+)\s+\"([^\"\<])\s+\<(.)\>\"/;
241	$fullname \|\|= $email;
242	if ($userid && $fullname && $email) {
243	my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
244	$userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
245	} else {
246	CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
247	}
248	$i++;
249	while (($painted/76) < ($i/@lines)) {
250	$CPAN::Frontend->myprint(".");
251	$painted++;
252	}
253	return if $CPAN::Signal;
254	}
255	$CPAN::Frontend->myprint("DONE\n");
256	}
257
258	sub userid {
259	my($self,$dist) = @_;
260	$dist = $self->{'id'} unless defined $dist;
261	my($ret) = $dist =~ m\|(?:\w/\w\w/)?([^/]+)/\|;
262	$ret;
263	}
264
265	#-> sub CPAN::Index::rd_modpacks ;
266	sub rd_modpacks {
267	my($self, $index_target) = @_;
268	return unless defined $index_target;
269	return if CPAN::_sqlite_running();
270	$CPAN::Frontend->myprint("Going to read '$index_target'\n");
271	my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
272	local $_;
273	CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
274	my $slurp = "";
275	my $chunk;
276	while (my $bytes = $fh->READ(\$chunk,8192)) {
277	$slurp.=$chunk;
278	}
279	my @lines = split /\012/, $slurp;
280	CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
281	undef $fh;
282	# read header
283	my($line_count,$last_updated);
284	while (@lines) {
285	my $shift = shift(@lines);
286	last if $shift =~ /^\s*$/;
287	$shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
288	$shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
289	}
290	CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
291	if (not defined $line_count) {
292
293	$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
294	Please check the validity of the index file by comparing it to more
295	than one CPAN mirror. I'll continue but problems seem likely to
296	happen.\a
297	});
298
299	$CPAN::Frontend->mysleep(5);
300	} elsif ($line_count != scalar @lines) {
301
302	$CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
303	contains a Line-Count header of %d but I see %d lines there. Please
304	check the validity of the index file by comparing it to more than one
305	CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
306	$index_target, $line_count, scalar(@lines));
307
308	}
309	if (not defined $last_updated) {
310
311	$CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
312	Please check the validity of the index file by comparing it to more
313	than one CPAN mirror. I'll continue but problems seem likely to
314	happen.\a
315	});
316
317	$CPAN::Frontend->mysleep(5);
318	} else {
319
320	$CPAN::Frontend
321	->myprint(sprintf qq{ Database was generated on %s\n},
322	$last_updated);
323	$DATE_OF_02 = $last_updated;
324
325	my $age = time;
326	if ($CPAN::META->has_inst('HTTP::Date')) {
327	require HTTP::Date;
328	$age -= HTTP::Date::str2time($last_updated);
329	} else {
330	$CPAN::Frontend->mywarn(" HTTP::Date not available\n");
331	require Time::Local;
332	my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
333	$d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
334	$age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
335	}
336	$age /= 3600*24;
337	if ($age > 30) {
338
339	$CPAN::Frontend
340	->mywarn(sprintf
341	qq{Warning: This index file is %d days old.
342	Please check the host you chose as your CPAN mirror for staleness.
343	I'll continue but problems seem likely to happen.\a\n},
344	$age);
345
346	} elsif ($age < -1) {
347
348	$CPAN::Frontend
349	->mywarn(sprintf
350	qq{Warning: Your system date is %d days behind this index file!
351	System time: %s
352	Timestamp index file: %s
353	Please fix your system time, problems with the make command expected.\n},
354	-$age,
355	scalar gmtime,
356	$DATE_OF_02,
357	);
358
359	}
360	}
361
362
363	# A necessity since we have metadata_cache: delete what isn't
364	# there anymore
365	my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
366	CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
367	my(%exists);
368	my $i = 0;
369	my $painted = 0;
370	foreach (@lines) {
371	# before 1.56 we split into 3 and discarded the rest. From
372	# 1.57 we assign remaining text to $comment thus allowing to
373	# influence isa_perl
374	my($mod,$version,$dist,$comment) = split " ", $_, 4;
375	unless ($mod && defined $version && $dist) {
376	$CPAN::Frontend->mywarn("Could not split line[$_]\n");
377	next;
378	}
379	my($bundle,$id,$userid);
380
381	if ($mod eq 'CPAN' &&
382	! (
383	CPAN::Queue->exists('Bundle::CPAN') \|\|
384	CPAN::Queue->exists('CPAN')
385	)
386	) {
387	local($^W)= 0;
388	if ($version > $CPAN::VERSION) {
389	$CPAN::Frontend->mywarn(qq{
390	New CPAN.pm version (v$version) available.
391	[Currently running version is v$CPAN::VERSION]
392	You might want to try
393	install CPAN
394	reload cpan
395	to both upgrade CPAN.pm and run the new version without leaving
396	the current session.
397
398	}); #});
399	$CPAN::Frontend->mysleep(2);
400	$CPAN::Frontend->myprint(qq{\n});
401	}
402	last if $CPAN::Signal;
403	} elsif ($mod =~ /^Bundle::(.*)/) {
404	$bundle = $1;
405	}
406
407	if ($bundle) {
408	$id = $CPAN::META->instance('CPAN::Bundle',$mod);
409	# Let's make it a module too, because bundles have so much
410	# in common with modules.
411
412	# Changed in 1.57_63: seems like memory bloat now without
413	# any value, so commented out
414
415	# $CPAN::META->instance('CPAN::Module',$mod);
416
417	} else {
418
419	# instantiate a module object
420	$id = $CPAN::META->instance('CPAN::Module',$mod);
421
422	}
423
424	# Although CPAN prohibits same name with different version the
425	# indexer may have changed the version for the same distro
426	# since the last time ("Force Reindexing" feature)
427	if ($id->cpan_file ne $dist
428	\|\|
429	$id->cpan_version ne $version
430	) {
431	$userid = $id->userid \|\| $self->userid($dist);
432	$id->set(
433	'CPAN_USERID' => $userid,
434	'CPAN_VERSION' => $version,
435	'CPAN_FILE' => $dist,
436	);
437	}
438
439	# instantiate a distribution object
440	if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
441	# we do not need CONTAINSMODS unless we do something with
442	# this dist, so we better produce it on demand.
443
444	## my $obj = $CPAN::META->instance(
445	## 'CPAN::Distribution' => $dist
446	## );
447	## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
448	} else {
449	$CPAN::META->instance(
450	'CPAN::Distribution' => $dist
451	)->set(
452	'CPAN_USERID' => $userid,
453	'CPAN_COMMENT' => $comment,
454	);
455	}
456	if ($secondtime) {
457	for my $name ($mod,$dist) {
458	# $self->debug("exists name[$name]") if $CPAN::DEBUG;
459	$exists{$name} = undef;
460	}
461	}
462	$i++;
463	while (($painted/76) < ($i/@lines)) {
464	$CPAN::Frontend->myprint(".");
465	$painted++;
466	}
467	return if $CPAN::Signal;
468	}
469	$CPAN::Frontend->myprint("DONE\n");
470	if ($secondtime) {
471	for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
472	for my $o ($CPAN::META->all_objects($class)) {
473	next if exists $exists{$o->{ID}};
474	$CPAN::META->delete($class,$o->{ID});
475	# CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
476	# if $CPAN::DEBUG;
477	}
478	}
479	}
480	}
481
482	#-> sub CPAN::Index::rd_modlist ;
483	sub rd_modlist {
484	my($cl,$index_target) = @_;
485	return unless defined $index_target;
486	return if CPAN::_sqlite_running();
487	$CPAN::Frontend->myprint("Going to read '$index_target'\n");
488	my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
489	local $_;
490	my $slurp = "";
491	my $chunk;
492	while (my $bytes = $fh->READ(\$chunk,8192)) {
493	$slurp.=$chunk;
494	}
495	my @eval2 = split /\012/, $slurp;
496
497	while (@eval2) {
498	my $shift = shift(@eval2);
499	if ($shift =~ /^Date:\s+(.*)/) {
500	if ($DATE_OF_03 eq $1) {
501	$CPAN::Frontend->myprint("Unchanged.\n");
502	return;
503	}
504	($DATE_OF_03) = $1;
505	}
506	last if $shift =~ /^\s*$/;
507	}
508	push @eval2, q{CPAN::Modulelist->data;};
509	local($^W) = 0;
510	my($compmt) = Safe->new("CPAN::Safe1");
511	my($eval2) = join("\n", @eval2);
512	CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
513	my $ret = $compmt->reval($eval2);
514	Carp::confess($@) if $@;
515	return if $CPAN::Signal;
516	my $i = 0;
517	my $until = keys(%$ret);
518	my $painted = 0;
519	CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
520	for (keys %$ret) {
521	my $obj = $CPAN::META->instance("CPAN::Module",$_);
522	delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
523	$obj->set(%{$ret->{$_}});
524	$i++;
525	while (($painted/76) < ($i/$until)) {
526	$CPAN::Frontend->myprint(".");
527	$painted++;
528	}
529	return if $CPAN::Signal;
530	}
531	$CPAN::Frontend->myprint("DONE\n");
532	}
533
534	#-> sub CPAN::Index::write_metadata_cache ;
535	sub write_metadata_cache {
536	my($self) = @_;
537	return unless $CPAN::Config->{'cache_metadata'};
538	return if CPAN::_sqlite_running();
539	return unless $CPAN::META->has_usable("Storable");
540	my $cache;
541	foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
542	CPAN::Distribution)) {
543	$cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
544	}
545	my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
546	$cache->{last_time} = $LAST_TIME;
547	$cache->{DATE_OF_02} = $DATE_OF_02;
548	$cache->{PROTOCOL} = PROTOCOL;
549	$CPAN::Frontend->myprint("Going to write $metadata_file\n");
550	eval { Storable::nstore($cache, $metadata_file) };
551	$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
552	}
553
554	#-> sub CPAN::Index::read_metadata_cache ;
555	sub read_metadata_cache {
556	my($self) = @_;
557	return unless $CPAN::Config->{'cache_metadata'};
558	return if CPAN::_sqlite_running();
559	return unless $CPAN::META->has_usable("Storable");
560	my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
561	return unless -r $metadata_file and -f $metadata_file;
562	$CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
563	my $cache;
564	eval { $cache = Storable::retrieve($metadata_file) };
565	$CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
566	if (!$cache \|\| !UNIVERSAL::isa($cache, 'HASH')) {
567	$LAST_TIME = 0;
568	return;
569	}
570	if (exists $cache->{PROTOCOL}) {
571	if (PROTOCOL > $cache->{PROTOCOL}) {
572	$CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
573	"with protocol v%s, requiring v%s\n",
574	$cache->{PROTOCOL},
575	PROTOCOL)
576	);
577	return;
578	}
579	} else {
580	$CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
581	"with protocol v1.0\n");
582	return;
583	}
584	my $clcnt = 0;
585	my $idcnt = 0;
586	while(my($class,$v) = each %$cache) {
587	next unless $class =~ /^CPAN::/;
588	$CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
589	while (my($id,$ro) = each %$v) {
590	$CPAN::META->{readwrite}{$class}{$id} \|\|=
591	$class->new(ID=>$id, RO=>$ro);
592	$idcnt++;
593	}
594	$clcnt++;
595	}
596	unless ($clcnt) { # sanity check
597	$CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
598	return;
599	}
600	if ($idcnt < 1000) {
601	$CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
602	"in $metadata_file\n");
603	return;
604	}
605	$CPAN::META->{PROTOCOL} \|\|=
606	$cache->{PROTOCOL}; # reading does not up or downgrade, but it
607	# does initialize to some protocol
608	$LAST_TIME = $cache->{last_time};
609	$DATE_OF_02 = $cache->{DATE_OF_02};
610	$CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
611	if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
612	return;
613	}
614
615	1;