Commit | Line | Data |
f9916dde |
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 |
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 |
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 |
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 |
94 | if ($CPAN::DEBUG){ |
95 | $t2 = time; |
96 | $debug .= "03[".($t2 - $time)."]"; |
97 | $time = $t2; |
98 | } |
f9916dde |
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; |