1package CPAN::Index;
2use strict;
3use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
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
9sub PROTOCOL { 2.0 }
10
11#-> sub CPAN::Index::force_reload ;
12sub force_reload {
13    my($class) = @_;
14    $CPAN::Index::LAST_TIME = 0;
15    $class->reload(1);
16}
17
18my @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 ;
41sub 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
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        }
93        $self->write_metadata_cache;
94        if ($CPAN::DEBUG){
95            $t2 = time;
96            $debug .= "03[".($t2 - $time)."]";
97            $time = $t2;
98        }
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 ;
113sub 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 $start = CPAN::FTP::_mytime();
127    my @candidates = map { $_->[0] }
128        sort { $b->[1] <=> $a->[1] }
129            map { [ $_, -M File::Spec->catfile($d,$_) ] }
130                grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
131    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                    ));
138      DISTRO: for $i (0..$#candidates) {
139            my $dirent = $candidates[$i];
140            my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent), {loadblessed => 1})};
141            if ($@) {
142                warn "Error while parsing file '$dirent'; error: '$@'";
143                next DISTRO;
144            }
145            my $c = $y->[0];
146            if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
147                my $key = $c->{distribution}{ID};
148                for my $k (keys %{$c->{distribution}}) {
149                    if ($c->{distribution}{$k}
150                        && ref $c->{distribution}{$k}
151                        && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
152                        $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                        = $c->{distribution};
162                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                    delete $do->{$skipper};
176                }
177                if ($do->can("tested_ok_but_not_installed")) {
178                    if ($do->tested_ok_but_not_installed) {
179                        $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
180                    } else {
181                        next DISTRO;
182                    }
183                }
184                $restored++;
185            }
186            $i++;
187            while (($painted/76) < ($i/@candidates)) {
188                $CPAN::Frontend->myprint(".");
189                $painted++;
190            }
191        }
192    }
193    else {
194        $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
195    }
196    my $took = CPAN::FTP::_mytime() - $start;
197    $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 ;
206sub reload_x {
207    my($cl,$wanted,$localname,$force) = @_;
208    $force |= 2; # means we're dealing with an index here
209    CPAN::HandleConfig->load; # we should guarantee loading wherever
210                              # we rely on Config XXX
211    $localname ||= $wanted;
212    my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
213                                         $localname);
214    if (
215        -f $abs_wanted &&
216        -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
217        !($force & 1)
218       ) {
219        my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
220        $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
221                   qq{day$s. I\'ll use that.});
222        return $abs_wanted;
223    } else {
224        $force |= 1; # means we're quite serious about it.
225    }
226    return CPAN::FTP->localize($wanted,$abs_wanted,$force);
227}
228
229#-> sub CPAN::Index::rd_authindex ;
230sub rd_authindex {
231    my($cl, $index_target) = @_;
232    return unless defined $index_target;
233    return if CPAN::_sqlite_running();
234    my @lines;
235    $CPAN::Frontend->myprint("Reading '$index_target'\n");
236    local(*FH);
237    tie *FH, 'CPAN::Tarzip', $index_target;
238    local($/) = "\n";
239    local($_);
240    push @lines, split /\012/ while <FH>;
241    my $i = 0;
242    my $painted = 0;
243    foreach (@lines) {
244        my($userid,$fullname,$email) =
245            m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
246        $fullname ||= $email;
247        if ($userid && $fullname && $email) {
248            my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
249            $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
250        } else {
251            CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
252        }
253        $i++;
254        while (($painted/76) < ($i/@lines)) {
255            $CPAN::Frontend->myprint(".");
256            $painted++;
257        }
258        return if $CPAN::Signal;
259    }
260    $CPAN::Frontend->myprint("DONE\n");
261}
262
263sub userid {
264  my($self,$dist) = @_;
265  $dist = $self->{'id'} unless defined $dist;
266  my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
267  $ret;
268}
269
270#-> sub CPAN::Index::rd_modpacks ;
271sub rd_modpacks {
272    my($self, $index_target) = @_;
273    return unless defined $index_target;
274    return if CPAN::_sqlite_running();
275    $CPAN::Frontend->myprint("Reading '$index_target'\n");
276    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
277    local $_;
278    CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
279    my $slurp = "";
280    my $chunk;
281    while (my $bytes = $fh->READ(\$chunk,8192)) {
282        $slurp.=$chunk;
283    }
284    my @lines = split /\012/, $slurp;
285    CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
286    undef $fh;
287    # read header
288    my($line_count,$last_updated);
289    while (@lines) {
290        my $shift = shift(@lines);
291        last if $shift =~ /^\s*$/;
292        $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
293        $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
294    }
295    CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
296    my $errors = 0;
297    if (not defined $line_count) {
298
299        $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
300Please check the validity of the index file by comparing it to more
301than one CPAN mirror. I'll continue but problems seem likely to
302happen.\a
303});
304        $errors++;
305        $CPAN::Frontend->mysleep(5);
306    } elsif ($line_count != scalar @lines) {
307
308        $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
309contains a Line-Count header of %d but I see %d lines there. Please
310check the validity of the index file by comparing it to more than one
311CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
312$index_target, $line_count, scalar(@lines));
313
314    }
315    if (not defined $last_updated) {
316
317        $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
318Please check the validity of the index file by comparing it to more
319than one CPAN mirror. I'll continue but problems seem likely to
320happen.\a
321});
322        $errors++;
323        $CPAN::Frontend->mysleep(5);
324    } else {
325
326        $CPAN::Frontend
327            ->myprint(sprintf qq{  Database was generated on %s\n},
328                      $last_updated);
329        $DATE_OF_02 = $last_updated;
330
331        my $age = time;
332        if ($CPAN::META->has_inst('HTTP::Date')) {
333            require HTTP::Date;
334            $age -= HTTP::Date::str2time($last_updated);
335        } else {
336            $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
337            require Time::Local;
338            my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
339            $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
340            $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
341        }
342        $age /= 3600*24;
343        if ($age > 30) {
344
345            $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            $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    my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
372    CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
373    my(%exists);
374    my $i = 0;
375    my $painted = 0;
376 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        my($mod,$version,$dist,$comment) = split " ", $_, 4;
381        unless ($mod && defined $version && $dist) {
382            require Dumpvalue;
383            my $dv = Dumpvalue->new(tick => '"');
384            $CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
385            if ($errors++ >= 5){
386                $CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
387            }
388            next LINE;
389        }
390        my($bundle,$id,$userid);
391
392        if ($mod eq 'CPAN' &&
393            ! (
394            CPAN::Queue->exists('Bundle::CPAN') ||
395            CPAN::Queue->exists('CPAN')
396            )
397        ) {
398            local($^W)= 0;
399            if ($version > $CPAN::VERSION) {
400                $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                $CPAN::Frontend->mysleep(2);
411                $CPAN::Frontend->myprint(qq{\n});
412            }
413            last if $CPAN::Signal;
414        } elsif ($mod =~ /^Bundle::(.*)/) {
415            $bundle = $1;
416        }
417
418        if ($bundle) {
419            $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            $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        if ($id->cpan_file ne $dist
439            ||
440            $id->cpan_version ne $version
441           ) {
442            $userid = $id->userid || $self->userid($dist);
443            $id->set(
444                     'CPAN_USERID' => $userid,
445                     'CPAN_VERSION' => $version,
446                     'CPAN_FILE' => $dist,
447                    );
448        }
449
450        # instantiate a distribution object
451        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            $CPAN::META->instance(
461                                  'CPAN::Distribution' => $dist
462                                 )->set(
463                                        'CPAN_USERID' => $userid,
464                                        'CPAN_COMMENT' => $comment,
465                                       );
466        }
467        if ($secondtime) {
468            for my $name ($mod,$dist) {
469                # $self->debug("exists name[$name]") if $CPAN::DEBUG;
470                $exists{$name} = undef;
471            }
472        }
473        $i++;
474        while (($painted/76) < ($i/@lines)) {
475            $CPAN::Frontend->myprint(".");
476            $painted++;
477        }
478        return if $CPAN::Signal;
479    }
480    $CPAN::Frontend->myprint("DONE\n");
481    if ($secondtime) {
482        for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
483            for my $o ($CPAN::META->all_objects($class)) {
484                next if exists $exists{$o->{ID}};
485                $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 ;
494sub rd_modlist {
495    my($cl,$index_target) = @_;
496    return unless defined $index_target;
497    return if CPAN::_sqlite_running();
498    $CPAN::Frontend->myprint("Reading '$index_target'\n");
499    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
500    local $_;
501    my $slurp = "";
502    my $chunk;
503    while (my $bytes = $fh->READ(\$chunk,8192)) {
504        $slurp.=$chunk;
505    }
506    my @eval2 = split /\012/, $slurp;
507
508    while (@eval2) {
509        my $shift = shift(@eval2);
510        if ($shift =~ /^Date:\s+(.*)/) {
511            if ($DATE_OF_03 eq $1) {
512                $CPAN::Frontend->myprint("Unchanged.\n");
513                return;
514            }
515            ($DATE_OF_03) = $1;
516        }
517        last if $shift =~ /^\s*$/;
518    }
519    push @eval2, q{CPAN::Modulelist->data;};
520    local($^W) = 0;
521    my($compmt) = Safe->new("CPAN::Safe1");
522    my($eval2) = join("\n", @eval2);
523    CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
524    my $ret = $compmt->reval($eval2);
525    Carp::confess($@) if $@;
526    return if $CPAN::Signal;
527    my $i = 0;
528    my $until = keys(%$ret);
529    my $painted = 0;
530    CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
531    for (sort keys %$ret) {
532        my $obj = $CPAN::META->instance("CPAN::Module",$_);
533        delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
534        $obj->set(%{$ret->{$_}});
535        $i++;
536        while (($painted/76) < ($i/$until)) {
537            $CPAN::Frontend->myprint(".");
538            $painted++;
539        }
540        return if $CPAN::Signal;
541    }
542    $CPAN::Frontend->myprint("DONE\n");
543}
544
545#-> sub CPAN::Index::write_metadata_cache ;
546sub write_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 $cache;
552    foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
553                      CPAN::Distribution)) {
554        $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
555    }
556    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
557    $cache->{last_time} = $LAST_TIME;
558    $cache->{DATE_OF_02} = $DATE_OF_02;
559    $cache->{PROTOCOL} = PROTOCOL;
560    $CPAN::Frontend->myprint("Writing $metadata_file\n");
561    eval { Storable::nstore($cache, $metadata_file) };
562    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
563}
564
565#-> sub CPAN::Index::read_metadata_cache ;
566sub read_metadata_cache {
567    my($self) = @_;
568    return unless $CPAN::Config->{'cache_metadata'};
569    return if CPAN::_sqlite_running();
570    return unless $CPAN::META->has_usable("Storable");
571    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
572    return unless -r $metadata_file and -f $metadata_file;
573    $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
574    my $cache;
575    eval { $cache = Storable::retrieve($metadata_file) };
576    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
577    if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
578        $LAST_TIME = 0;
579        return;
580    }
581    if (exists $cache->{PROTOCOL}) {
582        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                                            PROTOCOL)
587                                   );
588            return;
589        }
590    } else {
591        $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
592                                "with protocol v1.0\n");
593        return;
594    }
595    my $clcnt = 0;
596    my $idcnt = 0;
597    while(my($class,$v) = each %$cache) {
598        next unless $class =~ /^CPAN::/;
599        $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
600        while (my($id,$ro) = each %$v) {
601            $CPAN::META->{readwrite}{$class}{$id} ||=
602                $class->new(ID=>$id, RO=>$ro);
603            $idcnt++;
604        }
605        $clcnt++;
606    }
607    unless ($clcnt) { # sanity check
608        $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
609        return;
610    }
611    if ($idcnt < 1000) {
612        $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
613                                 "in $metadata_file\n");
614        return;
615    }
616    $CPAN::META->{PROTOCOL} ||=
617        $cache->{PROTOCOL}; # reading does not up or downgrade, but it
618                            # does initialize to some protocol
619    $LAST_TIME = $cache->{last_time};
620    $DATE_OF_02 = $cache->{DATE_OF_02};
621    $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    return;
624}
625
6261;
627