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 && 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->tested_ok_but_not_installed) {
181 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
186 while (($painted/76) < ($i/@candidates)) {
187 $CPAN::Frontend->myprint(".");
191 my $took = CPAN::FTP::_mytime() - $start;
192 $CPAN::Frontend->myprint(sprintf(
193 "DONE\nRestored the state of %s (in %.4f secs)\n",
200 #-> sub CPAN::Index::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'},
211 -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
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.});
219 $force |= 1; # means we're quite serious about it.
221 return CPAN::FTP->localize($wanted,$abs_wanted,$force);
224 #-> sub CPAN::Index::rd_authindex ;
226 my($cl, $index_target) = @_;
227 return unless defined $index_target;
228 return if CPAN::_sqlite_running();
230 $CPAN::Frontend->myprint("Going to read '$index_target'\n");
232 tie *FH, 'CPAN::Tarzip', $index_target;
235 push @lines, split /\012/ while <FH>;
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);
246 CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
249 while (($painted/76) < ($i/@lines)) {
250 $CPAN::Frontend->myprint(".");
253 return if $CPAN::Signal;
255 $CPAN::Frontend->myprint("DONE\n");
259 my($self,$dist) = @_;
260 $dist = $self->{'id'} unless defined $dist;
261 my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
265 #-> sub CPAN::Index::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);
273 CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
276 while (my $bytes = $fh->READ(\$chunk,8192)) {
279 my @lines = split /\012/, $slurp;
280 CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
283 my($line_count,$last_updated);
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;
290 CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
291 if (not defined $line_count) {
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
299 $CPAN::Frontend->mysleep(5);
300 } elsif ($line_count != scalar @lines) {
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));
309 if (not defined $last_updated) {
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
317 $CPAN::Frontend->mysleep(5);
321 ->myprint(sprintf qq{ Database was generated on %s\n},
323 $DATE_OF_02 = $last_updated;
326 if ($CPAN::META->has_inst('HTTP::Date')) {
328 $age -= HTTP::Date::str2time($last_updated);
330 $CPAN::Frontend->mywarn(" HTTP::Date not available\n");
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;
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},
346 } elsif ($age < -1) {
350 qq{Warning: Your system date is %d days behind this index file!
352 Timestamp index file: %s
353 Please fix your system time, problems with the make command expected.\n},
363 # A necessity since we have metadata_cache: delete what isn't
365 my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
366 CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
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
374 my($mod,$version,$dist,$comment) = split " ", $_, 4;
375 unless ($mod && defined $version && $dist) {
376 $CPAN::Frontend->mywarn("Could not split line[$_]\n");
379 my($bundle,$id,$userid);
381 if ($mod eq 'CPAN' &&
383 CPAN::Queue->exists('Bundle::CPAN') ||
384 CPAN::Queue->exists('CPAN')
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
395 to both upgrade CPAN.pm and run the new version without leaving
399 $CPAN::Frontend->mysleep(2);
400 $CPAN::Frontend->myprint(qq{\n});
402 last if $CPAN::Signal;
403 } elsif ($mod =~ /^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.
412 # Changed in 1.57_63: seems like memory bloat now without
413 # any value, so commented out
415 # $CPAN::META->instance('CPAN::Module',$mod);
419 # instantiate a module object
420 $id = $CPAN::META->instance('CPAN::Module',$mod);
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
429 $id->cpan_version ne $version
431 $userid = $id->userid || $self->userid($dist);
433 'CPAN_USERID' => $userid,
434 'CPAN_VERSION' => $version,
435 'CPAN_FILE' => $dist,
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.
444 ## my $obj = $CPAN::META->instance(
445 ## 'CPAN::Distribution' => $dist
447 ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
449 $CPAN::META->instance(
450 'CPAN::Distribution' => $dist
452 'CPAN_USERID' => $userid,
453 'CPAN_COMMENT' => $comment,
457 for my $name ($mod,$dist) {
458 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
459 $exists{$name} = undef;
463 while (($painted/76) < ($i/@lines)) {
464 $CPAN::Frontend->myprint(".");
467 return if $CPAN::Signal;
469 $CPAN::Frontend->myprint("DONE\n");
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]")
482 #-> sub CPAN::Index::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);
492 while (my $bytes = $fh->READ(\$chunk,8192)) {
495 my @eval2 = split /\012/, $slurp;
498 my $shift = shift(@eval2);
499 if ($shift =~ /^Date:\s+(.*)/) {
500 if ($DATE_OF_03 eq $1) {
501 $CPAN::Frontend->myprint("Unchanged.\n");
506 last if $shift =~ /^\s*$/;
508 push @eval2, q{CPAN::Modulelist->data;};
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;
517 my $until = keys(%$ret);
519 CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
521 my $obj = $CPAN::META->instance("CPAN::Module",$_);
522 delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
523 $obj->set(%{$ret->{$_}});
525 while (($painted/76) < ($i/$until)) {
526 $CPAN::Frontend->myprint(".");
529 return if $CPAN::Signal;
531 $CPAN::Frontend->myprint("DONE\n");
534 #-> sub CPAN::Index::write_metadata_cache ;
535 sub write_metadata_cache {
537 return unless $CPAN::Config->{'cache_metadata'};
538 return if CPAN::_sqlite_running();
539 return unless $CPAN::META->has_usable("Storable");
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
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 ??
554 #-> sub CPAN::Index::read_metadata_cache ;
555 sub read_metadata_cache {
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");
564 eval { $cache = Storable::retrieve($metadata_file) };
565 $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
566 if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
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",
580 $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
581 "with protocol v1.0\n");
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);
596 unless ($clcnt) { # sanity check
597 $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
601 $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
602 "in $metadata_file\n");
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