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]; | |
6b1bef9a | 149 | if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) { |
f9916dde A |
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 | } | |
6b1bef9a A |
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}); | |
183 | } else { | |
184 | next DISTRO; | |
185 | } | |
f9916dde A |
186 | } |
187 | $restored++; | |
188 | } | |
189 | $i++; | |
190 | while (($painted/76) < ($i/@candidates)) { | |
191 | $CPAN::Frontend->myprint("."); | |
192 | $painted++; | |
193 | } | |
194 | } | |
195 | my $took = CPAN::FTP::_mytime() - $start; | |
196 | $CPAN::Frontend->myprint(sprintf( | |
197 | "DONE\nRestored the state of %s (in %.4f secs)\n", | |
198 | $restored || "none", | |
199 | $took, | |
200 | )); | |
201 | } | |
202 | ||
203 | ||
204 | #-> sub CPAN::Index::reload_x ; | |
205 | sub 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'}, | |
212 | $localname); | |
213 | if ( | |
214 | -f $abs_wanted && | |
215 | -M $abs_wanted < $CPAN::Config->{'index_expire'} && | |
216 | !($force & 1) | |
217 | ) { | |
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.}); | |
221 | return $abs_wanted; | |
222 | } else { | |
223 | $force |= 1; # means we're quite serious about it. | |
224 | } | |
225 | return CPAN::FTP->localize($wanted,$abs_wanted,$force); | |
226 | } | |
227 | ||
228 | #-> sub CPAN::Index::rd_authindex ; | |
229 | sub rd_authindex { | |
230 | my($cl, $index_target) = @_; | |
231 | return unless defined $index_target; | |
232 | return if CPAN::_sqlite_running(); | |
233 | my @lines; | |
234 | $CPAN::Frontend->myprint("Going to read '$index_target'\n"); | |
235 | local(*FH); | |
236 | tie *FH, 'CPAN::Tarzip', $index_target; | |
237 | local($/) = "\n"; | |
238 | local($_); | |
239 | push @lines, split /\012/ while <FH>; | |
240 | my $i = 0; | |
241 | my $painted = 0; | |
242 | foreach (@lines) { | |
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); | |
249 | } else { | |
250 | CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG; | |
251 | } | |
252 | $i++; | |
253 | while (($painted/76) < ($i/@lines)) { | |
254 | $CPAN::Frontend->myprint("."); | |
255 | $painted++; | |
256 | } | |
257 | return if $CPAN::Signal; | |
258 | } | |
259 | $CPAN::Frontend->myprint("DONE\n"); | |
260 | } | |
261 | ||
262 | sub userid { | |
263 | my($self,$dist) = @_; | |
264 | $dist = $self->{'id'} unless defined $dist; | |
265 | my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|; | |
266 | $ret; | |
267 | } | |
268 | ||
269 | #-> sub CPAN::Index::rd_modpacks ; | |
270 | sub 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); | |
276 | local $_; | |
277 | CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG; | |
278 | my $slurp = ""; | |
279 | my $chunk; | |
280 | while (my $bytes = $fh->READ(\$chunk,8192)) { | |
281 | $slurp.=$chunk; | |
282 | } | |
283 | my @lines = split /\012/, $slurp; | |
284 | CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG; | |
285 | undef $fh; | |
286 | # read header | |
287 | my($line_count,$last_updated); | |
288 | while (@lines) { | |
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; | |
293 | } | |
294 | CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG; | |
295 | if (not defined $line_count) { | |
296 | ||
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 | |
300 | happen.\a | |
301 | }); | |
302 | ||
303 | $CPAN::Frontend->mysleep(5); | |
304 | } elsif ($line_count != scalar @lines) { | |
305 | ||
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)); | |
311 | ||
312 | } | |
313 | if (not defined $last_updated) { | |
314 | ||
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 | |
318 | happen.\a | |
319 | }); | |
320 | ||
321 | $CPAN::Frontend->mysleep(5); | |
322 | } else { | |
323 | ||
324 | $CPAN::Frontend | |
325 | ->myprint(sprintf qq{ Database was generated on %s\n}, | |
326 | $last_updated); | |
327 | $DATE_OF_02 = $last_updated; | |
328 | ||
329 | my $age = time; | |
330 | if ($CPAN::META->has_inst('HTTP::Date')) { | |
331 | require HTTP::Date; | |
332 | $age -= HTTP::Date::str2time($last_updated); | |
333 | } else { | |
334 | $CPAN::Frontend->mywarn(" HTTP::Date not available\n"); | |
335 | require Time::Local; | |
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; | |
339 | } | |
340 | $age /= 3600*24; | |
341 | if ($age > 30) { | |
342 | ||
343 | $CPAN::Frontend | |
344 | ->mywarn(sprintf | |
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}, | |
348 | $age); | |
349 | ||
350 | } elsif ($age < -1) { | |
351 | ||
352 | $CPAN::Frontend | |
353 | ->mywarn(sprintf | |
354 | qq{Warning: Your system date is %d days behind this index file! | |
355 | System time: %s | |
356 | Timestamp index file: %s | |
357 | Please fix your system time, problems with the make command expected.\n}, | |
358 | -$age, | |
359 | scalar gmtime, | |
360 | $DATE_OF_02, | |
361 | ); | |
362 | ||
363 | } | |
364 | } | |
365 | ||
366 | ||
367 | # A necessity since we have metadata_cache: delete what isn't | |
368 | # there anymore | |
369 | my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN"); | |
370 | CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG; | |
371 | my(%exists); | |
372 | my $i = 0; | |
373 | my $painted = 0; | |
374 | foreach (@lines) { | |
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 | |
377 | # influence isa_perl | |
378 | my($mod,$version,$dist,$comment) = split " ", $_, 4; | |
379 | unless ($mod && defined $version && $dist) { | |
380 | $CPAN::Frontend->mywarn("Could not split line[$_]\n"); | |
381 | next; | |
382 | } | |
383 | my($bundle,$id,$userid); | |
384 | ||
385 | if ($mod eq 'CPAN' && | |
386 | ! ( | |
387 | CPAN::Queue->exists('Bundle::CPAN') || | |
388 | CPAN::Queue->exists('CPAN') | |
389 | ) | |
390 | ) { | |
391 | local($^W)= 0; | |
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 | |
397 | install CPAN | |
398 | reload cpan | |
399 | to both upgrade CPAN.pm and run the new version without leaving | |
400 | the current session. | |
401 | ||
402 | }); #}); | |
403 | $CPAN::Frontend->mysleep(2); | |
404 | $CPAN::Frontend->myprint(qq{\n}); | |
405 | } | |
406 | last if $CPAN::Signal; | |
407 | } elsif ($mod =~ /^Bundle::(.*)/) { | |
408 | $bundle = $1; | |
409 | } | |
410 | ||
411 | if ($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. | |
415 | ||
416 | # Changed in 1.57_63: seems like memory bloat now without | |
417 | # any value, so commented out | |
418 | ||
419 | # $CPAN::META->instance('CPAN::Module',$mod); | |
420 | ||
421 | } else { | |
422 | ||
423 | # instantiate a module object | |
424 | $id = $CPAN::META->instance('CPAN::Module',$mod); | |
425 | ||
426 | } | |
427 | ||
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 | |
432 | || | |
433 | $id->cpan_version ne $version | |
434 | ) { | |
435 | $userid = $id->userid || $self->userid($dist); | |
436 | $id->set( | |
437 | 'CPAN_USERID' => $userid, | |
438 | 'CPAN_VERSION' => $version, | |
439 | 'CPAN_FILE' => $dist, | |
440 | ); | |
441 | } | |
442 | ||
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. | |
447 | ||
448 | ## my $obj = $CPAN::META->instance( | |
449 | ## 'CPAN::Distribution' => $dist | |
450 | ## ); | |
451 | ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental | |
452 | } else { | |
453 | $CPAN::META->instance( | |
454 | 'CPAN::Distribution' => $dist | |
455 | )->set( | |
456 | 'CPAN_USERID' => $userid, | |
457 | 'CPAN_COMMENT' => $comment, | |
458 | ); | |
459 | } | |
460 | if ($secondtime) { | |
461 | for my $name ($mod,$dist) { | |
462 | # $self->debug("exists name[$name]") if $CPAN::DEBUG; | |
463 | $exists{$name} = undef; | |
464 | } | |
465 | } | |
466 | $i++; | |
467 | while (($painted/76) < ($i/@lines)) { | |
468 | $CPAN::Frontend->myprint("."); | |
469 | $painted++; | |
470 | } | |
471 | return if $CPAN::Signal; | |
472 | } | |
473 | $CPAN::Frontend->myprint("DONE\n"); | |
474 | if ($secondtime) { | |
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]") | |
480 | # if $CPAN::DEBUG; | |
481 | } | |
482 | } | |
483 | } | |
484 | } | |
485 | ||
486 | #-> sub CPAN::Index::rd_modlist ; | |
487 | sub 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); | |
493 | local $_; | |
494 | my $slurp = ""; | |
495 | my $chunk; | |
496 | while (my $bytes = $fh->READ(\$chunk,8192)) { | |
497 | $slurp.=$chunk; | |
498 | } | |
499 | my @eval2 = split /\012/, $slurp; | |
500 | ||
501 | while (@eval2) { | |
502 | my $shift = shift(@eval2); | |
503 | if ($shift =~ /^Date:\s+(.*)/) { | |
504 | if ($DATE_OF_03 eq $1) { | |
505 | $CPAN::Frontend->myprint("Unchanged.\n"); | |
506 | return; | |
507 | } | |
508 | ($DATE_OF_03) = $1; | |
509 | } | |
510 | last if $shift =~ /^\s*$/; | |
511 | } | |
512 | push @eval2, q{CPAN::Modulelist->data;}; | |
513 | local($^W) = 0; | |
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; | |
520 | my $i = 0; | |
521 | my $until = keys(%$ret); | |
522 | my $painted = 0; | |
523 | CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG; | |
524 | for (keys %$ret) { | |
525 | my $obj = $CPAN::META->instance("CPAN::Module",$_); | |
526 | delete $ret->{$_}{modid}; # not needed here, maybe elsewhere | |
527 | $obj->set(%{$ret->{$_}}); | |
528 | $i++; | |
529 | while (($painted/76) < ($i/$until)) { | |
530 | $CPAN::Frontend->myprint("."); | |
531 | $painted++; | |
532 | } | |
533 | return if $CPAN::Signal; | |
534 | } | |
535 | $CPAN::Frontend->myprint("DONE\n"); | |
536 | } | |
537 | ||
538 | #-> sub CPAN::Index::write_metadata_cache ; | |
539 | sub write_metadata_cache { | |
540 | my($self) = @_; | |
541 | return unless $CPAN::Config->{'cache_metadata'}; | |
542 | return if CPAN::_sqlite_running(); | |
543 | return unless $CPAN::META->has_usable("Storable"); | |
544 | my $cache; | |
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 | |
548 | } | |
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 ?? | |
556 | } | |
557 | ||
558 | #-> sub CPAN::Index::read_metadata_cache ; | |
559 | sub read_metadata_cache { | |
560 | my($self) = @_; | |
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"); | |
567 | my $cache; | |
568 | eval { $cache = Storable::retrieve($metadata_file) }; | |
569 | $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ?? | |
570 | if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) { | |
571 | $LAST_TIME = 0; | |
572 | return; | |
573 | } | |
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", | |
578 | $cache->{PROTOCOL}, | |
579 | PROTOCOL) | |
580 | ); | |
581 | return; | |
582 | } | |
583 | } else { | |
584 | $CPAN::Frontend->mywarn("Ignoring Metadata cache written ". | |
585 | "with protocol v1.0\n"); | |
586 | return; | |
587 | } | |
588 | my $clcnt = 0; | |
589 | my $idcnt = 0; | |
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); | |
596 | $idcnt++; | |
597 | } | |
598 | $clcnt++; | |
599 | } | |
600 | unless ($clcnt) { # sanity check | |
601 | $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n"); | |
602 | return; | |
603 | } | |
604 | if ($idcnt < 1000) { | |
605 | $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ". | |
606 | "in $metadata_file\n"); | |
607 | return; | |
608 | } | |
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 | |
616 | return; | |
617 | } | |
618 | ||
619 | 1; |