3 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
5 @CPAN::Index::ISA = qw(CPAN::Debug);
8 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
11 #-> sub CPAN::Index::force_reload ;
14 $CPAN::Index::LAST_TIME = 0;
21 reader => "rd_authindex",
23 remotefile => '01mailrc.txt.gz',
24 shortlocalfile => '01mailrc.gz',
27 reader => "rd_modpacks",
29 remotefile => '02packages.details.txt.gz',
30 shortlocalfile => '02packag.gz',
33 reader => "rd_modlist",
35 remotefile => '03modlist.data.gz',
36 shortlocalfile => '03mlist.gz',
40 #-> sub CPAN::Index::reload ;
42 my($self,$force) = @_;
45 # XXX check if a newer one is available. (We currently read it
47 for ($CPAN::Config->{index_expire}) {
48 $_ = 0.001 unless $_ && $_ > 0.001;
50 unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
51 # debug here when CPAN doesn't seem to read the Metadata
53 Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
55 unless ($CPAN::META->{PROTOCOL}) {
56 $self->read_metadata_cache;
57 $CPAN::META->{PROTOCOL} ||= "1.0";
59 if ( $CPAN::META->{PROTOCOL} < PROTOCOL ) {
60 # warn "Setting last_time to 0";
61 $LAST_TIME = 0; # No warning necessary
63 if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
66 # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
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;
74 local $LAST_TIME = $time;
75 local $CPAN::META->{PROTOCOL} = PROTOCOL;
77 my $needshort = $^O eq "dos";
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
88 $debug = "timing reading 01[".($t2 - $time)."]";
91 return if $CPAN::Signal; # this is sometimes lengthy
93 $self->write_metadata_cache;
96 $debug .= "03[".($t2 - $time)."]";
99 CPAN->debug($debug) if $CPAN::DEBUG;
101 if ($CPAN::Config->{build_dir_reuse}) {
102 $self->reanimate_build_dir;
104 if (CPAN::_sqlite_running()) {
105 $CPAN::SQLite->reload(time => $time, force => $force)
109 $CPAN::META->{PROTOCOL} = PROTOCOL;
112 #-> sub CPAN::Index::reanimate_build_dir ;
113 sub reanimate_build_dir {
115 unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
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
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");
134 $CPAN::Frontend->myprint
135 (sprintf("Going to read %d yaml file%s from %s/\n",
137 @candidates==1 ? "" : "s",
138 $CPAN::Config->{build_dir}
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))};
145 warn "Error while parsing file '$dirent'; error: '$@'";
149 if ($c && $c->{perl} && $c->{distribution} && 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;
159 #we tried to restore only if element already
160 #exists; but then we do not work with metadata
163 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
164 = $c->{distribution};
167 configure_requires_later
168 configure_requires_later_for
178 delete $do->{$skipper};
180 if ($do->can("tested_ok_but_not_installed")) {
181 if ($do->tested_ok_but_not_installed) {
182 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
190 while (($painted/76) < ($i/@candidates)) {
191 $CPAN::Frontend->myprint(".");
195 my $took = CPAN::FTP::_mytime() - $start;
196 $CPAN::Frontend->myprint(sprintf(
197 "DONE\nRestored the state of %s (in %.4f secs)\n",
204 #-> sub CPAN::Index::reload_x ;
206 my($cl,$wanted,$localname,$force) = @_;
207 $force |= 2; # means we're dealing with an index here
208 CPAN::HandleConfig->load; # we should guarantee loading wherever
209 # we rely on Config XXX
210 $localname ||= $wanted;
211 my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
215 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
218 my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
219 $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
220 qq{day$s. I\'ll use that.});
223 $force |= 1; # means we're quite serious about it.
225 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
228 #-> sub CPAN::Index::rd_authindex ;
230 my($cl, $index_target) = @_;
231 return unless defined $index_target;
232 return if CPAN::_sqlite_running();
234 $CPAN::Frontend->myprint("Going to read '$index_target'\n");
236 tie *FH, 'CPAN::Tarzip', $index_target;
239 push @lines, split /\012/ while <FH>;
243 my($userid,$fullname,$email) =
244 m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
245 $fullname ||= $email;
246 if ($userid && $fullname && $email) {
247 my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
248 $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
250 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
253 while (($painted/76) < ($i/@lines)) {
254 $CPAN::Frontend->myprint(".");
257 return if $CPAN::Signal;
259 $CPAN::Frontend->myprint("DONE\n");
263 my($self,$dist) = @_;
264 $dist = $self->{'id'} unless defined $dist;
265 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
269 #-> sub CPAN::Index::rd_modpacks ;
271 my($self, $index_target) = @_;
272 return unless defined $index_target;
273 return if CPAN::_sqlite_running();
274 $CPAN::Frontend->myprint("Going to read '$index_target'\n");
275 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
277 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
280 while (my $bytes = $fh->READ(\$chunk,8192)) {
283 my @lines = split /\012/, $slurp;
284 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
287 my($line_count,$last_updated);
289 my $shift = shift(@lines);
290 last if $shift =~ /^\s*$/;
291 $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
292 $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
294 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
295 if (not defined $line_count) {
297 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
298 Please check the validity of the index file by comparing it to more
299 than one CPAN mirror. I'll continue but problems seem likely to
303 $CPAN::Frontend->mysleep(5);
304 } elsif ($line_count != scalar @lines) {
306 $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
307 contains a Line-Count header of %d but I see %d lines there. Please
308 check the validity of the index file by comparing it to more than one
309 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
310 $index_target, $line_count, scalar(@lines));
313 if (not defined $last_updated) {
315 $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
316 Please check the validity of the index file by comparing it to more
317 than one CPAN mirror. I'll continue but problems seem likely to
321 $CPAN::Frontend->mysleep(5);
325 ->myprint(sprintf qq{ Database was generated on %s\n},
327 $DATE_OF_02 = $last_updated;
330 if ($CPAN::META->has_inst('HTTP::Date')) {
332 $age -= HTTP::Date::str2time($last_updated);
334 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
336 my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
337 $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
338 $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
345 qq{Warning: This index file is %d days old.
346 Please check the host you chose as your CPAN mirror for staleness.
347 I'll continue but problems seem likely to happen.\a\n},
350 } elsif ($age < -1) {
354 qq{Warning: Your system date is %d days behind this index file!
356 Timestamp index file: %s
357 Please fix your system time, problems with the make command expected.\n},
367 # A necessity since we have metadata_cache: delete what isn't
369 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
370 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
375 # before 1.56 we split into 3 and discarded the rest. From
376 # 1.57 we assign remaining text to $comment thus allowing to
378 my($mod,$version,$dist,$comment) = split " ", $_, 4;
379 unless ($mod && defined $version && $dist) {
380 $CPAN::Frontend->mywarn("Could not split line[$_]\n");
383 my($bundle,$id,$userid);
385 if ($mod eq 'CPAN' &&
387 CPAN::Queue->exists('Bundle::CPAN') ||
388 CPAN::Queue->exists('CPAN')
392 if ($version > $CPAN::VERSION) {
393 $CPAN::Frontend->mywarn(qq{
394 New CPAN.pm version (v$version) available.
395 [Currently running version is v$CPAN::VERSION]
396 You might want to try
399 to both upgrade CPAN.pm and run the new version without leaving
403 $CPAN::Frontend->mysleep(2);
404 $CPAN::Frontend->myprint(qq{\n});
406 last if $CPAN::Signal;
407 } elsif ($mod =~ /^Bundle::(.*)/) {
412 $id = $CPAN::META->instance('CPAN::Bundle',$mod);
413 # Let's make it a module too, because bundles have so much
414 # in common with modules.
416 # Changed in 1.57_63: seems like memory bloat now without
417 # any value, so commented out
419 # $CPAN::META->instance('CPAN::Module',$mod);
423 # instantiate a module object
424 $id = $CPAN::META->instance('CPAN::Module',$mod);
428 # Although CPAN prohibits same name with different version the
429 # indexer may have changed the version for the same distro
430 # since the last time ("Force Reindexing" feature)
431 if ($id->cpan_file ne $dist
433 $id->cpan_version ne $version
435 $userid = $id->userid || $self->userid($dist);
437 'CPAN_USERID' => $userid,
438 'CPAN_VERSION' => $version,
439 'CPAN_FILE' => $dist,
443 # instantiate a distribution object
444 if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
445 # we do not need CONTAINSMODS unless we do something with
446 # this dist, so we better produce it on demand.
448 ## my $obj = $CPAN::META->instance(
449 ## 'CPAN::Distribution' => $dist
451 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
453 $CPAN::META->instance(
454 'CPAN::Distribution' => $dist
456 'CPAN_USERID' => $userid,
457 'CPAN_COMMENT' => $comment,
461 for my $name ($mod,$dist) {
462 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
463 $exists{$name} = undef;
467 while (($painted/76) < ($i/@lines)) {
468 $CPAN::Frontend->myprint(".");
471 return if $CPAN::Signal;
473 $CPAN::Frontend->myprint("DONE\n");
475 for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
476 for my $o ($CPAN::META->all_objects($class)) {
477 next if exists $exists{$o->{ID}};
478 $CPAN::META->delete($class,$o->{ID});
479 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
486 #-> sub CPAN::Index::rd_modlist ;
488 my($cl,$index_target) = @_;
489 return unless defined $index_target;
490 return if CPAN::_sqlite_running();
491 $CPAN::Frontend->myprint("Going to read '$index_target'\n");
492 my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
496 while (my $bytes = $fh->READ(\$chunk,8192)) {
499 my @eval2 = split /\012/, $slurp;
502 my $shift = shift(@eval2);
503 if ($shift =~ /^Date:\s+(.*)/) {
504 if ($DATE_OF_03 eq $1) {
505 $CPAN::Frontend->myprint("Unchanged.\n");
510 last if $shift =~ /^\s*$/;
512 push @eval2, q{CPAN::Modulelist->data;};
514 my($compmt) = Safe->new("CPAN::Safe1");
515 my($eval2) = join("\n", @eval2);
516 CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
517 my $ret = $compmt->reval($eval2);
518 Carp::confess($@) if $@;
519 return if $CPAN::Signal;
521 my $until = keys(%$ret);
523 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
525 my $obj = $CPAN::META->instance("CPAN::Module",$_);
526 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
527 $obj->set(%{$ret->{$_}});
529 while (($painted/76) < ($i/$until)) {
530 $CPAN::Frontend->myprint(".");
533 return if $CPAN::Signal;
535 $CPAN::Frontend->myprint("DONE\n");
538 #-> sub CPAN::Index::write_metadata_cache ;
539 sub write_metadata_cache {
541 return unless $CPAN::Config->{'cache_metadata'};
542 return if CPAN::_sqlite_running();
543 return unless $CPAN::META->has_usable("Storable");
545 foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
546 CPAN::Distribution)) {
547 $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
549 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
550 $cache->{last_time} = $LAST_TIME;
551 $cache->{DATE_OF_02} = $DATE_OF_02;
552 $cache->{PROTOCOL} = PROTOCOL;
553 $CPAN::Frontend->myprint("Going to write $metadata_file\n");
554 eval { Storable::nstore($cache, $metadata_file) };
555 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
558 #-> sub CPAN::Index::read_metadata_cache ;
559 sub read_metadata_cache {
561 return unless $CPAN::Config->{'cache_metadata'};
562 return if CPAN::_sqlite_running();
563 return unless $CPAN::META->has_usable("Storable");
564 my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
565 return unless -r $metadata_file and -f $metadata_file;
566 $CPAN::Frontend->myprint("Going to read '$metadata_file'\n");
568 eval { $cache = Storable::retrieve($metadata_file) };
569 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
570 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
574 if (exists $cache->{PROTOCOL}) {
575 if (PROTOCOL > $cache->{PROTOCOL}) {
576 $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
577 "with protocol v%s, requiring v%s\n",
584 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
585 "with protocol v1.0\n");
590 while(my($class,$v) = each %$cache) {
591 next unless $class =~ /^CPAN::/;
592 $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
593 while (my($id,$ro) = each %$v) {
594 $CPAN::META->{readwrite}{$class}{$id} ||=
595 $class->new(ID=>$id, RO=>$ro);
600 unless ($clcnt) { # sanity check
601 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
605 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
606 "in $metadata_file\n");
609 $CPAN::META->{PROTOCOL} ||=
610 $cache->{PROTOCOL}; # reading does not up or downgrade, but it
611 # does initialize to some protocol
612 $LAST_TIME = $cache->{last_time};
613 $DATE_OF_02 = $cache->{DATE_OF_02};
614 $CPAN::Frontend->myprint(" Database was generated on $DATE_OF_02\n")
615 if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02