File Coverage

blib/lib/CPAN/Index.pm
Criterion Covered Total %
statement 179 325 55.0
branch 61 172 35.4
condition 15 75 20.0
subroutine 11 13 84.6
pod 0 11 0.0
total 266 596 44.6


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