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