This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Less brace nesting.
[perl5.git] / lib / CPAN.pm
1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 use strict;
3 package CPAN;
4 $CPAN::VERSION = '1.88_54';
5 $CPAN::VERSION = eval $CPAN::VERSION;
6
7 use CPAN::HandleConfig;
8 use CPAN::Version;
9 use CPAN::Debug;
10 use CPAN::Queue;
11 use CPAN::Tarzip;
12 use Carp ();
13 use Config ();
14 use Cwd ();
15 use DirHandle ();
16 use Exporter ();
17 use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
18                                     # 5.005_04 does not work without
19                                     # this
20 use File::Basename ();
21 use File::Copy ();
22 use File::Find;
23 use File::Path ();
24 use File::Spec ();
25 use FileHandle ();
26 use Safe ();
27 use Sys::Hostname qw(hostname);
28 use Text::ParseWords ();
29 use Text::Wrap ();
30
31 # we need to run chdir all over and we would get at wrong libraries
32 # there
33 BEGIN {
34     if (File::Spec->can("rel2abs")) {
35         for my $inc (@INC) {
36             $inc = File::Spec->rel2abs($inc);
37         }
38     }
39 }
40 no lib ".";
41
42 require Mac::BuildTools if $^O eq 'MacOS';
43
44 END { $CPAN::End++; &cleanup; }
45
46 $CPAN::Signal ||= 0;
47 $CPAN::Frontend ||= "CPAN::Shell";
48 unless (@CPAN::Defaultsites){
49     @CPAN::Defaultsites = map {
50         CPAN::URL->new(TEXT => $_, FROM => "DEF")
51     }
52         "http://www.perl.org/CPAN/",
53             "ftp://ftp.perl.org/pub/CPAN/";
54 }
55 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
56 $CPAN::Perl ||= CPAN::find_perl();
57 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
58 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
59
60
61 use vars qw($VERSION @EXPORT $AUTOLOAD
62             $DEBUG $META $HAS_USABLE $term
63             $GOTOSHELL
64             $Signal $Suppress_readline $Frontend
65             @Defaultsites $Have_warned $Defaultdocs $Defaultrecent
66             $Be_Silent
67             $autoload_recursion
68            );
69
70 @CPAN::ISA = qw(CPAN::Debug Exporter);
71
72 # note that these functions live in CPAN::Shell and get executed via
73 # AUTOLOAD when called directly
74 @EXPORT = qw(
75              autobundle
76              bundle
77              clean
78              cvs_import
79              expand
80              force
81              get
82              install
83              make
84              mkmyconfig
85              notest
86              perldoc
87              readme
88              recent
89              recompile
90              shell
91              test
92              upgrade
93             );
94
95 sub soft_chdir_with_alternatives ($);
96
97 {
98     $autoload_recursion ||= 0;
99
100     #-> sub CPAN::AUTOLOAD ;
101     sub AUTOLOAD {
102         $autoload_recursion++;
103         my($l) = $AUTOLOAD;
104         $l =~ s/.*:://;
105         if ($CPAN::Signal) {
106             warn "Refusing to autoload '$l' while signal pending";
107             $autoload_recursion--;
108             return;
109         }
110         if ($autoload_recursion > 1) {
111             my $fullcommand = join " ", map { "'$_'" } $l, @_;
112             warn "Refusing to autoload $fullcommand in recursion\n";
113             $autoload_recursion--;
114             return;
115         }
116         my(%export);
117         @export{@EXPORT} = '';
118         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
119         if (exists $export{$l}){
120             CPAN::Shell->$l(@_);
121         } else {
122             die(qq{Unknown CPAN command "$AUTOLOAD". }.
123                 qq{Type ? for help.\n});
124         }
125         $autoload_recursion--;
126     }
127 }
128
129 #-> sub CPAN::shell ;
130 sub shell {
131     my($self) = @_;
132     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
133     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
134
135     my $oprompt = shift || CPAN::Prompt->new;
136     my $prompt = $oprompt;
137     my $commandline = shift || "";
138     $CPAN::CurrentCommandId ||= 1;
139
140     local($^W) = 1;
141     unless ($Suppress_readline) {
142         require Term::ReadLine;
143         if (! $term
144             or
145             $term->ReadLine eq "Term::ReadLine::Stub"
146            ) {
147             $term = Term::ReadLine->new('CPAN Monitor');
148         }
149         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
150             my $attribs = $term->Attribs;
151              $attribs->{attempted_completion_function} = sub {
152                  &CPAN::Complete::gnu_cpl;
153              }
154         } else {
155             $readline::rl_completion_function =
156                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
157         }
158         if (my $histfile = $CPAN::Config->{'histfile'}) {{
159             unless ($term->can("AddHistory")) {
160                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
161                 last;
162             }
163             my($fh) = FileHandle->new;
164             open $fh, "<$histfile" or last;
165             local $/ = "\n";
166             while (<$fh>) {
167                 chomp;
168                 $term->AddHistory($_);
169             }
170             close $fh;
171         }}
172         for ($CPAN::Config->{term_ornaments}) { # alias
173             local $Term::ReadLine::termcap_nowarn = 1;
174             $term->ornaments($_) if defined;
175         }
176         # $term->OUT is autoflushed anyway
177         my $odef = select STDERR;
178         $| = 1;
179         select STDOUT;
180         $| = 1;
181         select $odef;
182     }
183
184     # no strict; # I do not recall why no strict was here (2000-09-03)
185     $META->checklock();
186     my @cwd = grep { defined $_ and length $_ }
187         CPAN::anycwd(),
188               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
189                     File::Spec->rootdir();
190     my $try_detect_readline;
191     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
192     my $rl_avail = $Suppress_readline ? "suppressed" :
193         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
194             "available (try 'install Bundle::CPAN')";
195
196     unless ($CPAN::Config->{'inhibit_startup_message'}){
197         $CPAN::Frontend->myprint(
198                                  sprintf qq{
199 cpan shell -- CPAN exploration and modules installation (v%s)
200 ReadLine support %s
201
202 },
203                                  $CPAN::VERSION,
204                                  $rl_avail
205                                 )
206     }
207     my($continuation) = "";
208     my $last_term_ornaments;
209   SHELLCOMMAND: while () {
210         if ($Suppress_readline) {
211             print $prompt;
212             last SHELLCOMMAND unless defined ($_ = <> );
213             chomp;
214         } else {
215             last SHELLCOMMAND unless
216                 defined ($_ = $term->readline($prompt, $commandline));
217         }
218         $_ = "$continuation$_" if $continuation;
219         s/^\s+//;
220         next SHELLCOMMAND if /^$/;
221         $_ = 'h' if /^\s*\?/;
222         if (/^(?:q(?:uit)?|bye|exit)$/i) {
223             last SHELLCOMMAND;
224         } elsif (s/\\$//s) {
225             chomp;
226             $continuation = $_;
227             $prompt = "    > ";
228         } elsif (/^\!/) {
229             s/^\!//;
230             my($eval) = $_;
231             package CPAN::Eval;
232             use strict;
233             use vars qw($import_done);
234             CPAN->import(':DEFAULT') unless $import_done++;
235             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
236             eval($eval);
237             warn $@ if $@;
238             $continuation = "";
239             $prompt = $oprompt;
240         } elsif (/./) {
241             my(@line);
242             eval { @line = Text::ParseWords::shellwords($_) };
243             warn($@), next SHELLCOMMAND if $@;
244             warn("Text::Parsewords could not parse the line [$_]"),
245                 next SHELLCOMMAND unless @line;
246             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
247             my $command = shift @line;
248             eval { CPAN::Shell->$command(@line) };
249             warn $@ if $@;
250             if ($command =~ /^(make|test|install|force|notest|clean|upgrade)$/) {
251                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
252             }
253             soft_chdir_with_alternatives(\@cwd);
254             $CPAN::Frontend->myprint("\n");
255             $continuation = "";
256             $CPAN::CurrentCommandId++;
257             $prompt = $oprompt;
258         }
259     } continue {
260       $commandline = ""; # I do want to be able to pass a default to
261                          # shell, but on the second command I see no
262                          # use in that
263       $Signal=0;
264       CPAN::Queue->nullify_queue;
265       if ($try_detect_readline) {
266         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
267             ||
268             $CPAN::META->has_inst("Term::ReadLine::Perl")
269            ) {
270             delete $INC{"Term/ReadLine.pm"};
271             my $redef = 0;
272             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
273             require Term::ReadLine;
274             $CPAN::Frontend->myprint("\n$redef subroutines in ".
275                                      "Term::ReadLine redefined\n");
276             $GOTOSHELL = 1;
277         }
278       }
279       if ($term and $term->can("ornaments")) {
280           for ($CPAN::Config->{term_ornaments}) { # alias
281               if (defined $_) {
282                   if (not defined $last_term_ornaments
283                       or $_ != $last_term_ornaments
284                      ) {
285                       local $Term::ReadLine::termcap_nowarn = 1;
286                       $term->ornaments($_);
287                       $last_term_ornaments = $_;
288                   }
289               } else {
290                   undef $last_term_ornaments;
291               }
292           }
293       }
294       if ($CPAN::DEBUG && $CPAN::DEBUG & $CPAN::DEBUG{CPAN}) {
295           # debugging 'incommandcolor': should always be off at the end of a command
296           # (incommandcolor is used to detect recursive dependencies)
297           for my $class (qw(Module Distribution)) {
298               for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
299                   next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
300                   CPAN->debug("BUG: $class '$dm' was in command state, resetting");
301                   delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
302               }
303           }
304       }
305       if ($GOTOSHELL) {
306           $GOTOSHELL = 0; # not too often
307           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
308           @_ = ($oprompt,"");
309           goto &shell;
310       }
311     }
312     soft_chdir_with_alternatives(\@cwd);
313 }
314
315 sub soft_chdir_with_alternatives ($) {
316     my($cwd) = @_;
317     unless (@$cwd) {
318         my $root = File::Spec->rootdir();
319         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
320 Trying '$root' as temporary haven.
321 });
322         push @$cwd, $root;
323     }
324     while () {
325         if (chdir $cwd->[0]) {
326             return;
327         } else {
328             if (@$cwd>1) {
329                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
330 Trying to chdir to "$cwd->[1]" instead.
331 });
332                 shift @$cwd;
333             } else {
334                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
335             }
336         }
337     }
338 }
339
340 # CPAN::_yaml_loadfile
341 sub _yaml_loadfile {
342     my($self,$local_file) = @_;
343     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
344     if ($CPAN::META->has_inst($yaml_module)) {
345         my $code = UNIVERSAL::can($yaml_module, "LoadFile");
346         my $yaml;
347         eval { $yaml = $code->($local_file); };
348         if ($@) {
349             $CPAN::Frontend->mydie("Alert: While trying to parse YAML file\n".
350                                    "  $local_file\n".
351                                    "with $yaml_module the following error was encountered:\n".
352                                    "  $@\n"
353                                   );
354         }
355         return $yaml;
356     } else {
357         $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot parse '$local_file'\n");
358     }
359     return +{};
360 }
361
362 package CPAN::CacheMgr;
363 use strict;
364 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
365 use File::Find;
366
367 package CPAN::FTP;
368 use strict;
369 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
370 @CPAN::FTP::ISA = qw(CPAN::Debug);
371
372 package CPAN::LWP::UserAgent;
373 use strict;
374 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
375 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
376
377 package CPAN::Complete;
378 use strict;
379 @CPAN::Complete::ISA = qw(CPAN::Debug);
380 @CPAN::Complete::COMMANDS = sort qw(
381                                     ! a b d h i m o q r u
382                                     autobundle
383                                     clean
384                                     cvs_import
385                                     dump
386                                     force
387                                     install
388                                     look
389                                     ls
390                                     make
391                                     mkmyconfig
392                                     notest
393                                     perldoc
394                                     readme
395                                     recent
396                                     recompile
397                                     reload
398                                     scripts
399                                     test
400                                     upgrade
401 );
402
403 package CPAN::Index;
404 use strict;
405 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03);
406 @CPAN::Index::ISA = qw(CPAN::Debug);
407 $LAST_TIME ||= 0;
408 $DATE_OF_03 ||= 0;
409 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
410 sub PROTOCOL { 2.0 }
411
412 package CPAN::InfoObj;
413 use strict;
414 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
415
416 package CPAN::Author;
417 use strict;
418 @CPAN::Author::ISA = qw(CPAN::InfoObj);
419
420 package CPAN::Distribution;
421 use strict;
422 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
423
424 package CPAN::Bundle;
425 use strict;
426 @CPAN::Bundle::ISA = qw(CPAN::Module);
427
428 package CPAN::Module;
429 use strict;
430 @CPAN::Module::ISA = qw(CPAN::InfoObj);
431
432 package CPAN::Exception::RecursiveDependency;
433 use strict;
434 use overload '""' => "as_string";
435
436 sub new {
437     my($class) = shift;
438     my($deps) = shift;
439     my @deps;
440     my %seen;
441     for my $dep (@$deps) {
442         push @deps, $dep;
443         last if $seen{$dep}++;
444     }
445     bless { deps => \@deps }, $class;
446 }
447
448 sub as_string {
449     my($self) = shift;
450     "\nRecursive dependency detected:\n    " .
451         join("\n => ", @{$self->{deps}}) .
452             ".\nCannot continue.\n";
453 }
454
455 package CPAN::Prompt; use overload '""' => "as_string";
456 use vars qw($prompt);
457 $prompt = "cpan> ";
458 $CPAN::CurrentCommandId ||= 0;
459 sub new {
460     bless {}, shift;
461 }
462 sub as_string {
463     if ($CPAN::Config->{commandnumber_in_prompt}) {
464         sprintf "cpan[%d]> ", $CPAN::CurrentCommandId;
465     } else {
466         "cpan> ";
467     }
468 }
469
470 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
471 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
472 # planned are things like age or quality
473 sub new {
474     my($class,%args) = @_;
475     bless {
476            %args
477           }, $class;
478 }
479 sub as_string {
480     my($self) = @_;
481     $self->text;
482 }
483 sub text {
484     my($self,$set) = @_;
485     if (defined $set) {
486         $self->{TEXT} = $set;
487     }
488     $self->{TEXT};
489 }
490
491 package CPAN::Distrostatus;
492 use overload '""' => "as_string",
493     fallback => 1;
494 sub new {
495     my($class,$arg) = @_;
496     bless {
497            TEXT => $arg,
498            FAILED => substr($arg,0,2) eq "NO",
499            COMMANDID => $CPAN::CurrentCommandId,
500           }, $class;
501 }
502 sub commandid { shift->{COMMANDID} }
503 sub failed { shift->{FAILED} }
504 sub text {
505     my($self,$set) = @_;
506     if (defined $set) {
507         $self->{TEXT} = $set;
508     }
509     $self->{TEXT};
510 }
511 sub as_string {
512     my($self) = @_;
513     $self->text;
514 }
515
516 package CPAN::Shell;
517 use strict;
518 use vars qw(
519             $ADVANCED_QUERY
520             $AUTOLOAD
521             $COLOR_REGISTERED
522             $autoload_recursion
523             $reload
524             @ISA
525            );
526 @CPAN::Shell::ISA = qw(CPAN::Debug);
527 $COLOR_REGISTERED ||= 0;
528
529 {
530     # $GLOBAL_AUTOLOAD_RECURSION = 12;
531     $autoload_recursion   ||= 0;
532
533     #-> sub CPAN::Shell::AUTOLOAD ;
534     sub AUTOLOAD {
535         $autoload_recursion++;
536         my($l) = $AUTOLOAD;
537         my $class = shift(@_);
538         # warn "autoload[$l] class[$class]";
539         $l =~ s/.*:://;
540         if ($CPAN::Signal) {
541             warn "Refusing to autoload '$l' while signal pending";
542             $autoload_recursion--;
543             return;
544         }
545         if ($autoload_recursion > 1) {
546             my $fullcommand = join " ", map { "'$_'" } $l, @_;
547             warn "Refusing to autoload $fullcommand in recursion\n";
548             $autoload_recursion--;
549             return;
550         }
551         if ($l =~ /^w/) {
552             # XXX needs to be reconsidered
553             if ($CPAN::META->has_inst('CPAN::WAIT')) {
554                 CPAN::WAIT->$l(@_);
555             } else {
556                 $CPAN::Frontend->mywarn(qq{
557 Commands starting with "w" require CPAN::WAIT to be installed.
558 Please consider installing CPAN::WAIT to use the fulltext index.
559 For this you just need to type
560     install CPAN::WAIT
561 });
562             }
563         } else {
564             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
565                                     qq{Type ? for help.
566 });
567         }
568         $autoload_recursion--;
569     }
570 }
571
572 package CPAN;
573 use strict;
574
575 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
576
577 # from here on only subs.
578 ################################################################################
579
580 sub suggest_myconfig () {
581   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
582         $CPAN::Frontend->myprint("You don't seem to have a user ".
583                                  "configuration (MyConfig.pm) yet.\n");
584         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
585                                               "user configuration now? (Y/n)",
586                                               "yes");
587         if($new =~ m{^y}i) {
588             CPAN::Shell->mkmyconfig();
589             return &checklock;
590         } else {
591             $CPAN::Frontend->mydie("OK, giving up.");
592         }
593     }
594 }
595
596 #-> sub CPAN::all_objects ;
597 sub all_objects {
598     my($mgr,$class) = @_;
599     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
600     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
601     CPAN::Index->reload;
602     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
603 }
604
605 # Called by shell, not in batch mode. In batch mode I see no risk in
606 # having many processes updating something as installations are
607 # continually checked at runtime. In shell mode I suspect it is
608 # unintentional to open more than one shell at a time
609
610 #-> sub CPAN::checklock ;
611 sub checklock {
612     my($self) = @_;
613     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
614     if (-f $lockfile && -M _ > 0) {
615         my $fh = FileHandle->new($lockfile) or
616             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
617         my $otherpid  = <$fh>;
618         my $otherhost = <$fh>;
619         $fh->close;
620         if (defined $otherpid && $otherpid) {
621             chomp $otherpid;
622         }
623         if (defined $otherhost && $otherhost) {
624             chomp $otherhost;
625         }
626         my $thishost  = hostname();
627         if (defined $otherhost && defined $thishost &&
628             $otherhost ne '' && $thishost ne '' &&
629             $otherhost ne $thishost) {
630             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
631                                            "reports other host $otherhost and other ".
632                                            "process $otherpid.\n".
633                                            "Cannot proceed.\n"));
634         }
635         elsif (defined $otherpid && $otherpid) {
636             return if $$ == $otherpid; # should never happen
637             $CPAN::Frontend->mywarn(
638                                     qq{
639 There seems to be running another CPAN process (pid $otherpid).  Contacting...
640 });
641             if (kill 0, $otherpid) {
642                 $CPAN::Frontend->mydie(qq{Other job is running.
643 You may want to kill it and delete the lockfile, maybe. On UNIX try:
644     kill $otherpid
645     rm $lockfile
646 });
647             } elsif (-w $lockfile) {
648                 my($ans) =
649                     CPAN::Shell::colorable_makemaker_prompt
650                         (qq{Other job not responding. Shall I overwrite }.
651                          qq{the lockfile '$lockfile'? (Y/n)},"y");
652                 $CPAN::Frontend->myexit("Ok, bye\n")
653                     unless $ans =~ /^y/i;
654             } else {
655                 Carp::croak(
656                             qq{Lockfile '$lockfile' not writeable by you. }.
657                             qq{Cannot proceed.\n}.
658                             qq{    On UNIX try:\n}.
659                             qq{    rm '$lockfile'\n}.
660                             qq{  and then rerun us.\n}
661                            );
662             }
663         } else {
664             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
665                                            "reports other process with ID ".
666                                            "$otherpid. Cannot proceed.\n"));
667         }
668     }
669     my $dotcpan = $CPAN::Config->{cpan_home};
670     eval { File::Path::mkpath($dotcpan);};
671     if ($@) {
672         # A special case at least for Jarkko.
673         my $firsterror = $@;
674         my $seconderror;
675         my $symlinkcpan;
676         if (-l $dotcpan) {
677             $symlinkcpan = readlink $dotcpan;
678             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
679             eval { File::Path::mkpath($symlinkcpan); };
680             if ($@) {
681                 $seconderror = $@;
682             } else {
683                 $CPAN::Frontend->mywarn(qq{
684 Working directory $symlinkcpan created.
685 });
686             }
687         }
688         unless (-d $dotcpan) {
689             my $mess = qq{
690 Your configuration suggests "$dotcpan" as your
691 CPAN.pm working directory. I could not create this directory due
692 to this error: $firsterror\n};
693             $mess .= qq{
694 As "$dotcpan" is a symlink to "$symlinkcpan",
695 I tried to create that, but I failed with this error: $seconderror
696 } if $seconderror;
697             $mess .= qq{
698 Please make sure the directory exists and is writable.
699 };
700             $CPAN::Frontend->myprint($mess);
701             return suggest_myconfig;
702         }
703     } # $@ after eval mkpath $dotcpan
704     my $fh;
705     unless ($fh = FileHandle->new(">$lockfile")) {
706         if ($! =~ /Permission/) {
707             $CPAN::Frontend->myprint(qq{
708
709 Your configuration suggests that CPAN.pm should use a working
710 directory of
711     $CPAN::Config->{cpan_home}
712 Unfortunately we could not create the lock file
713     $lockfile
714 due to permission problems.
715
716 Please make sure that the configuration variable
717     \$CPAN::Config->{cpan_home}
718 points to a directory where you can write a .lock file. You can set
719 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
720 \@INC path;
721 });
722             return suggest_myconfig;
723         }
724     }
725     $fh->print($$, "\n");
726     $fh->print(hostname(), "\n");
727     $self->{LOCK} = $lockfile;
728     $fh->close;
729     $SIG{TERM} = sub {
730         my $sig = shift;
731         &cleanup;
732         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
733     };
734     $SIG{INT} = sub {
735       # no blocks!!!
736         my $sig = shift;
737         &cleanup if $Signal;
738         die "Got yet another signal" if $Signal > 1;
739         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
740         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
741         $Signal++;
742     };
743
744 #       From: Larry Wall <larry@wall.org>
745 #       Subject: Re: deprecating SIGDIE
746 #       To: perl5-porters@perl.org
747 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
748 #
749 #       The original intent of __DIE__ was only to allow you to substitute one
750 #       kind of death for another on an application-wide basis without respect
751 #       to whether you were in an eval or not.  As a global backstop, it should
752 #       not be used any more lightly (or any more heavily :-) than class
753 #       UNIVERSAL.  Any attempt to build a general exception model on it should
754 #       be politely squashed.  Any bug that causes every eval {} to have to be
755 #       modified should be not so politely squashed.
756 #
757 #       Those are my current opinions.  It is also my optinion that polite
758 #       arguments degenerate to personal arguments far too frequently, and that
759 #       when they do, it's because both people wanted it to, or at least didn't
760 #       sufficiently want it not to.
761 #
762 #       Larry
763
764     # global backstop to cleanup if we should really die
765     $SIG{__DIE__} = \&cleanup;
766     $self->debug("Signal handler set.") if $CPAN::DEBUG;
767 }
768
769 #-> sub CPAN::DESTROY ;
770 sub DESTROY {
771     &cleanup; # need an eval?
772 }
773
774 #-> sub CPAN::anycwd ;
775 sub anycwd () {
776     my $getcwd;
777     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
778     CPAN->$getcwd();
779 }
780
781 #-> sub CPAN::cwd ;
782 sub cwd {Cwd::cwd();}
783
784 #-> sub CPAN::getcwd ;
785 sub getcwd {Cwd::getcwd();}
786
787 #-> sub CPAN::fastcwd ;
788 sub fastcwd {Cwd::fastcwd();}
789
790 #-> sub CPAN::backtickcwd ;
791 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
792
793 #-> sub CPAN::find_perl ;
794 sub find_perl {
795     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
796     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
797     my $candidate = File::Spec->catfile($pwd,$^X);
798     $perl ||= $candidate if MM->maybe_command($candidate);
799
800     unless ($perl) {
801         my ($component,$perl_name);
802       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
803             PATH_COMPONENT: foreach $component (File::Spec->path(),
804                                                 $Config::Config{'binexp'}) {
805                   next unless defined($component) && $component;
806                   my($abs) = File::Spec->catfile($component,$perl_name);
807                   if (MM->maybe_command($abs)) {
808                       $perl = $abs;
809                       last DIST_PERLNAME;
810                   }
811               }
812           }
813     }
814
815     return $perl;
816 }
817
818
819 #-> sub CPAN::exists ;
820 sub exists {
821     my($mgr,$class,$id) = @_;
822     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
823     CPAN::Index->reload;
824     ### Carp::croak "exists called without class argument" unless $class;
825     $id ||= "";
826     $id =~ s/:+/::/g if $class eq "CPAN::Module";
827     exists $META->{readonly}{$class}{$id} or
828         exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
829 }
830
831 #-> sub CPAN::delete ;
832 sub delete {
833   my($mgr,$class,$id) = @_;
834   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
835   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
836 }
837
838 #-> sub CPAN::has_usable
839 # has_inst is sometimes too optimistic, we should replace it with this
840 # has_usable whenever a case is given
841 sub has_usable {
842     my($self,$mod,$message) = @_;
843     return 1 if $HAS_USABLE->{$mod};
844     my $has_inst = $self->has_inst($mod,$message);
845     return unless $has_inst;
846     my $usable;
847     $usable = {
848                LWP => [ # we frequently had "Can't locate object
849                         # method "new" via package "LWP::UserAgent" at
850                         # (eval 69) line 2006
851                        sub {require LWP},
852                        sub {require LWP::UserAgent},
853                        sub {require HTTP::Request},
854                        sub {require URI::URL},
855                       ],
856                'Net::FTP' => [
857                             sub {require Net::FTP},
858                             sub {require Net::Config},
859                            ],
860                'File::HomeDir' => [
861                                    sub {require File::HomeDir;
862                                         unless (File::HomeDir->VERSION >= 0.52){
863                                             for ("Will not use File::HomeDir, need 0.52\n") {
864                                                 $CPAN::Frontend->mywarn($_);
865                                                 die $_;
866                                             }
867                                         }
868                                     },
869                                   ],
870               };
871     if ($usable->{$mod}) {
872         for my $c (0..$#{$usable->{$mod}}) {
873             my $code = $usable->{$mod}[$c];
874             my $ret = eval { &$code() };
875             $ret = "" unless defined $ret;
876             if ($@) {
877                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
878                 return;
879             }
880         }
881     }
882     return $HAS_USABLE->{$mod} = 1;
883 }
884
885 #-> sub CPAN::has_inst
886 sub has_inst {
887     my($self,$mod,$message) = @_;
888     Carp::croak("CPAN->has_inst() called without an argument")
889         unless defined $mod;
890     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
891         keys %{$CPAN::Config->{dontload_hash}||{}},
892             @{$CPAN::Config->{dontload_list}||[]};
893     if (defined $message && $message eq "no"  # afair only used by Nox
894         ||
895         $dont{$mod}
896        ) {
897       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
898       return 0;
899     }
900     my $file = $mod;
901     my $obj;
902     $file =~ s|::|/|g;
903     $file .= ".pm";
904     if ($INC{$file}) {
905         # checking %INC is wrong, because $INC{LWP} may be true
906         # although $INC{"URI/URL.pm"} may have failed. But as
907         # I really want to say "bla loaded OK", I have to somehow
908         # cache results.
909         ### warn "$file in %INC"; #debug
910         return 1;
911     } elsif (eval { require $file }) {
912         # eval is good: if we haven't yet read the database it's
913         # perfect and if we have installed the module in the meantime,
914         # it tries again. The second require is only a NOOP returning
915         # 1 if we had success, otherwise it's retrying
916
917         my $v = eval "\$$mod\::VERSION";
918         $v = $v ? " (v$v)" : "";
919         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
920         if ($mod eq "CPAN::WAIT") {
921             push @CPAN::Shell::ISA, 'CPAN::WAIT';
922         }
923         return 1;
924     } elsif ($mod eq "Net::FTP") {
925         $CPAN::Frontend->mywarn(qq{
926   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
927   if you just type
928       install Bundle::libnet
929
930 }) unless $Have_warned->{"Net::FTP"}++;
931         $CPAN::Frontend->mysleep(3);
932     } elsif ($mod eq "Digest::SHA"){
933         if ($Have_warned->{"Digest::SHA"}++) {
934             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled}.
935                                      qq{because Digest::SHA not installed.\n});
936         } else {
937             $CPAN::Frontend->mywarn(qq{
938   CPAN: checksum security checks disabled because Digest::SHA not installed.
939   Please consider installing the Digest::SHA module.
940
941 });
942             $CPAN::Frontend->mysleep(2);
943         }
944     } elsif ($mod eq "Module::Signature"){
945         if (not $CPAN::Config->{check_sigs}) {
946             # they do not want us:-(
947         } elsif (not $Have_warned->{"Module::Signature"}++) {
948             # No point in complaining unless the user can
949             # reasonably install and use it.
950             if (eval { require Crypt::OpenPGP; 1 } ||
951                 (
952                  defined $CPAN::Config->{'gpg'}
953                  &&
954                  $CPAN::Config->{'gpg'} =~ /\S/
955                 )
956                ) {
957                 $CPAN::Frontend->mywarn(qq{
958   CPAN: Module::Signature security checks disabled because Module::Signature
959   not installed.  Please consider installing the Module::Signature module.
960   You may also need to be able to connect over the Internet to the public
961   keyservers like pgp.mit.edu (port 11371).
962
963 });
964                 $CPAN::Frontend->mysleep(2);
965             }
966         }
967     } else {
968         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
969     }
970     return 0;
971 }
972
973 #-> sub CPAN::instance ;
974 sub instance {
975     my($mgr,$class,$id) = @_;
976     CPAN::Index->reload;
977     $id ||= "";
978     # unsafe meta access, ok?
979     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
980     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
981 }
982
983 #-> sub CPAN::new ;
984 sub new {
985     bless {}, shift;
986 }
987
988 #-> sub CPAN::cleanup ;
989 sub cleanup {
990   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
991   local $SIG{__DIE__} = '';
992   my($message) = @_;
993   my $i = 0;
994   my $ineval = 0;
995   my($subroutine);
996   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
997       $ineval = 1, last if
998           $subroutine eq '(eval)';
999   }
1000   return if $ineval && !$CPAN::End;
1001   return unless defined $META->{LOCK};
1002   return unless -f $META->{LOCK};
1003   $META->savehist;
1004   unlink $META->{LOCK};
1005   # require Carp;
1006   # Carp::cluck("DEBUGGING");
1007   $CPAN::Frontend->myprint("Lockfile removed.\n");
1008 }
1009
1010 #-> sub CPAN::savehist
1011 sub savehist {
1012     my($self) = @_;
1013     my($histfile,$histsize);
1014     unless ($histfile = $CPAN::Config->{'histfile'}){
1015         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1016         return;
1017     }
1018     $histsize = $CPAN::Config->{'histsize'} || 100;
1019     if ($CPAN::term){
1020         unless ($CPAN::term->can("GetHistory")) {
1021             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1022             return;
1023         }
1024     } else {
1025         return;
1026     }
1027     my @h = $CPAN::term->GetHistory;
1028     splice @h, 0, @h-$histsize if @h>$histsize;
1029     my($fh) = FileHandle->new;
1030     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1031     local $\ = local $, = "\n";
1032     print $fh @h;
1033     close $fh;
1034 }
1035
1036 sub is_tested {
1037     my($self,$what) = @_;
1038     $self->{is_tested}{$what} = 1;
1039 }
1040
1041 # unsets the is_tested flag: as soon as the thing is installed, it is
1042 # not needed in set_perl5lib anymore
1043 sub is_installed {
1044     my($self,$what) = @_;
1045     delete $self->{is_tested}{$what};
1046 }
1047
1048 sub set_perl5lib {
1049     my($self) = @_;
1050     $self->{is_tested} ||= {};
1051     return unless %{$self->{is_tested}};
1052     my $env = $ENV{PERL5LIB};
1053     $env = $ENV{PERLLIB} unless defined $env;
1054     my @env;
1055     push @env, $env if defined $env and length $env;
1056     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1057     $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1058     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1059 }
1060
1061 package CPAN::CacheMgr;
1062 use strict;
1063
1064 #-> sub CPAN::CacheMgr::as_string ;
1065 sub as_string {
1066     eval { require Data::Dumper };
1067     if ($@) {
1068         return shift->SUPER::as_string;
1069     } else {
1070         return Data::Dumper::Dumper(shift);
1071     }
1072 }
1073
1074 #-> sub CPAN::CacheMgr::cachesize ;
1075 sub cachesize {
1076     shift->{DU};
1077 }
1078
1079 #-> sub CPAN::CacheMgr::tidyup ;
1080 sub tidyup {
1081   my($self) = @_;
1082   return unless -d $self->{ID};
1083   while ($self->{DU} > $self->{'MAX'} ) {
1084     my($toremove) = shift @{$self->{FIFO}};
1085     $CPAN::Frontend->myprint(sprintf(
1086                                      "Deleting from cache".
1087                                      ": $toremove (%.1f>%.1f MB)\n",
1088                                      $self->{DU}, $self->{'MAX'})
1089                             );
1090     return if $CPAN::Signal;
1091     $self->force_clean_cache($toremove);
1092     return if $CPAN::Signal;
1093   }
1094 }
1095
1096 #-> sub CPAN::CacheMgr::dir ;
1097 sub dir {
1098     shift->{ID};
1099 }
1100
1101 #-> sub CPAN::CacheMgr::entries ;
1102 sub entries {
1103     my($self,$dir) = @_;
1104     return unless defined $dir;
1105     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1106     $dir ||= $self->{ID};
1107     my($cwd) = CPAN::anycwd();
1108     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1109     my $dh = DirHandle->new(File::Spec->curdir)
1110         or Carp::croak("Couldn't opendir $dir: $!");
1111     my(@entries);
1112     for ($dh->read) {
1113         next if $_ eq "." || $_ eq "..";
1114         if (-f $_) {
1115             push @entries, File::Spec->catfile($dir,$_);
1116         } elsif (-d _) {
1117             push @entries, File::Spec->catdir($dir,$_);
1118         } else {
1119             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1120         }
1121     }
1122     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1123     sort { -M $b <=> -M $a} @entries;
1124 }
1125
1126 #-> sub CPAN::CacheMgr::disk_usage ;
1127 sub disk_usage {
1128     my($self,$dir) = @_;
1129     return if exists $self->{SIZE}{$dir};
1130     return if $CPAN::Signal;
1131     my($Du) = 0;
1132     if (-e $dir) {
1133         unless (-x $dir) {
1134             unless (chmod 0755, $dir) {
1135                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1136                                         "permission to change the permission; cannot ".
1137                                         "estimate disk usage of '$dir'\n");
1138                 $CPAN::Frontend->mysleep(5);
1139                 return;
1140             }
1141         }
1142     } else {
1143         $CPAN::Frontend->mywarn("Directory '$dir' has gone. Cannot continue.\n");
1144         return;
1145     }
1146     find(
1147          sub {
1148            $File::Find::prune++ if $CPAN::Signal;
1149            return if -l $_;
1150            if ($^O eq 'MacOS') {
1151              require Mac::Files;
1152              my $cat  = Mac::Files::FSpGetCatInfo($_);
1153              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1154            } else {
1155              if (-d _) {
1156                unless (-x _) {
1157                  unless (chmod 0755, $_) {
1158                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1159                                            "the permission to change the permission; ".
1160                                            "can only partially estimate disk usage ".
1161                                            "of '$_'\n");
1162                    $CPAN::Frontend->mysleep(5);
1163                    return;
1164                  }
1165                }
1166              } else {
1167                $Du += (-s _);
1168              }
1169            }
1170          },
1171          $dir
1172         );
1173     return if $CPAN::Signal;
1174     $self->{SIZE}{$dir} = $Du/1024/1024;
1175     push @{$self->{FIFO}}, $dir;
1176     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1177     $self->{DU} += $Du/1024/1024;
1178     $self->{DU};
1179 }
1180
1181 #-> sub CPAN::CacheMgr::force_clean_cache ;
1182 sub force_clean_cache {
1183     my($self,$dir) = @_;
1184     return unless -e $dir;
1185     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1186         if $CPAN::DEBUG;
1187     File::Path::rmtree($dir);
1188     $self->{DU} -= $self->{SIZE}{$dir};
1189     delete $self->{SIZE}{$dir};
1190 }
1191
1192 #-> sub CPAN::CacheMgr::new ;
1193 sub new {
1194     my $class = shift;
1195     my $time = time;
1196     my($debug,$t2);
1197     $debug = "";
1198     my $self = {
1199                 ID => $CPAN::Config->{'build_dir'},
1200                 MAX => $CPAN::Config->{'build_cache'},
1201                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1202                 DU => 0
1203                };
1204     File::Path::mkpath($self->{ID});
1205     my $dh = DirHandle->new($self->{ID});
1206     bless $self, $class;
1207     $self->scan_cache;
1208     $t2 = time;
1209     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1210     $time = $t2;
1211     CPAN->debug($debug) if $CPAN::DEBUG;
1212     $self;
1213 }
1214
1215 #-> sub CPAN::CacheMgr::scan_cache ;
1216 sub scan_cache {
1217     my $self = shift;
1218     return if $self->{SCAN} eq 'never';
1219     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1220         unless $self->{SCAN} eq 'atstart';
1221     $CPAN::Frontend->myprint(
1222                              sprintf("Scanning cache %s for sizes\n",
1223                                      $self->{ID}));
1224     my $e;
1225     for $e ($self->entries($self->{ID})) {
1226         next if $e eq ".." || $e eq ".";
1227         $self->disk_usage($e);
1228         return if $CPAN::Signal;
1229     }
1230     $self->tidyup;
1231 }
1232
1233 package CPAN::Shell;
1234 use strict;
1235
1236 #-> sub CPAN::Shell::h ;
1237 sub h {
1238     my($class,$about) = @_;
1239     if (defined $about) {
1240         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1241     } else {
1242         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1243         $CPAN::Frontend->myprint(qq{
1244 Display Information $filler (ver $CPAN::VERSION)
1245  command  argument          description
1246  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1247  i        WORD or /REGEXP/  about any of the above
1248  ls       AUTHOR or GLOB    about files in the author's directory
1249     (with WORD being a module, bundle or author name or a distribution
1250     name of the form AUTHOR/DISTRIBUTION)
1251
1252 Download, Test, Make, Install...
1253  get      download                     clean    make clean
1254  make     make (implies get)           look     open subshell in dist directory
1255  test     make test (implies make)     readme   display these README files
1256  install  make install (implies test)  perldoc  display POD documentation
1257
1258 Upgrade
1259  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1260  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1261
1262 Pragmas
1263  force COMMAND    unconditionally do command
1264  notest COMMAND   skip testing
1265
1266 Other
1267  h,?           display this menu       ! perl-code   eval a perl command
1268  o conf [opt]  set and query options   q             quit the cpan shell
1269  reload cpan   load CPAN.pm again      reload index  load newer indices
1270  autobundle    Snapshot                recent        latest CPAN uploads});
1271 }
1272 }
1273
1274 *help = \&h;
1275
1276 #-> sub CPAN::Shell::a ;
1277 sub a {
1278   my($self,@arg) = @_;
1279   # authors are always UPPERCASE
1280   for (@arg) {
1281     $_ = uc $_ unless /=/;
1282   }
1283   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1284 }
1285
1286 #-> sub CPAN::Shell::globls ;
1287 sub globls {
1288     my($self,$s,$pragmas) = @_;
1289     # ls is really very different, but we had it once as an ordinary
1290     # command in the Shell (upto rev. 321) and we could not handle
1291     # force well then
1292     my(@accept,@preexpand);
1293     if ($s =~ /[\*\?\/]/) {
1294         if ($CPAN::META->has_inst("Text::Glob")) {
1295             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1296                 my $rau = Text::Glob::glob_to_regex(uc $au);
1297                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1298                       if $CPAN::DEBUG;
1299                 push @preexpand, map { $_->id . "/" . $pathglob }
1300                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1301             } else {
1302                 my $rau = Text::Glob::glob_to_regex(uc $s);
1303                 push @preexpand, map { $_->id }
1304                     CPAN::Shell->expand_by_method('CPAN::Author',
1305                                                   ['id'],
1306                                                   "/$rau/");
1307             }
1308         } else {
1309             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1310         }
1311     } else {
1312         push @preexpand, uc $s;
1313     }
1314     for (@preexpand) {
1315         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1316             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1317             next;
1318         }
1319         push @accept, $_;
1320     }
1321     my $silent = @accept>1;
1322     my $last_alpha = "";
1323     my @results;
1324     for my $a (@accept){
1325         my($author,$pathglob);
1326         if ($a =~ m|(.*?)/(.*)|) {
1327             my $a2 = $1;
1328             $pathglob = $2;
1329             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1330                                                     ['id'],
1331                                                     $a2) or die "No author found for $a2";
1332         } else {
1333             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1334                                                     ['id'],
1335                                                     $a) or die "No author found for $a";
1336         }
1337         if ($silent) {
1338             my $alpha = substr $author->id, 0, 1;
1339             my $ad;
1340             if ($alpha eq $last_alpha) {
1341                 $ad = "";
1342             } else {
1343                 $ad = "[$alpha]";
1344                 $last_alpha = $alpha;
1345             }
1346             $CPAN::Frontend->myprint($ad);
1347         }
1348         for my $pragma (@$pragmas) {
1349             if ($author->can($pragma)) {
1350                 $author->$pragma();
1351             }
1352         }
1353         push @results, $author->ls($pathglob,$silent); # silent if
1354                                                        # more than one
1355                                                        # author
1356         for my $pragma (@$pragmas) {
1357             my $meth = "un$pragma";
1358             if ($author->can($meth)) {
1359                 $author->$meth();
1360             }
1361         }
1362     }
1363     @results;
1364 }
1365
1366 #-> sub CPAN::Shell::local_bundles ;
1367 sub local_bundles {
1368     my($self,@which) = @_;
1369     my($incdir,$bdir,$dh);
1370     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1371         my @bbase = "Bundle";
1372         while (my $bbase = shift @bbase) {
1373             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1374             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1375             if ($dh = DirHandle->new($bdir)) { # may fail
1376                 my($entry);
1377                 for $entry ($dh->read) {
1378                     next if $entry =~ /^\./;
1379                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1380                     if (-d File::Spec->catdir($bdir,$entry)){
1381                         push @bbase, "$bbase\::$entry";
1382                     } else {
1383                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1384                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1385                     }
1386                 }
1387             }
1388         }
1389     }
1390 }
1391
1392 #-> sub CPAN::Shell::b ;
1393 sub b {
1394     my($self,@which) = @_;
1395     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1396     $self->local_bundles;
1397     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1398 }
1399
1400 #-> sub CPAN::Shell::d ;
1401 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1402
1403 #-> sub CPAN::Shell::m ;
1404 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1405     my $self = shift;
1406     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1407 }
1408
1409 #-> sub CPAN::Shell::i ;
1410 sub i {
1411     my($self) = shift;
1412     my(@args) = @_;
1413     @args = '/./' unless @args;
1414     my(@result);
1415     for my $type (qw/Bundle Distribution Module/) {
1416         push @result, $self->expand($type,@args);
1417     }
1418     # Authors are always uppercase.
1419     push @result, $self->expand("Author", map { uc $_ } @args);
1420
1421     my $result = @result == 1 ?
1422         $result[0]->as_string :
1423             @result == 0 ?
1424                 "No objects found of any type for argument @args\n" :
1425                     join("",
1426                          (map {$_->as_glimpse} @result),
1427                          scalar @result, " items found\n",
1428                         );
1429     $CPAN::Frontend->myprint($result);
1430 }
1431
1432 #-> sub CPAN::Shell::o ;
1433
1434 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1435 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1436 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1437 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1438 sub o {
1439     my($self,$o_type,@o_what) = @_;
1440     $DB::single = 1;
1441     $o_type ||= "";
1442     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1443     if ($o_type eq 'conf') {
1444         if (!@o_what) { # print all things, "o conf"
1445             my($k,$v);
1446             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1447             my @from;
1448             if (exists $INC{'CPAN/Config.pm'}) {
1449                 push @from, $INC{'CPAN/Config.pm'};
1450             }
1451             if (exists $INC{'CPAN/MyConfig.pm'}) {
1452                 push @from, $INC{'CPAN/MyConfig.pm'};
1453             }
1454             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1455             $CPAN::Frontend->myprint(":\n");
1456             for $k (sort keys %CPAN::HandleConfig::can) {
1457                 $v = $CPAN::HandleConfig::can{$k};
1458                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1459             }
1460             $CPAN::Frontend->myprint("\n");
1461             for $k (sort keys %$CPAN::Config) {
1462                 CPAN::HandleConfig->prettyprint($k);
1463             }
1464             $CPAN::Frontend->myprint("\n");
1465         } elsif (!CPAN::HandleConfig->edit(@o_what)) {
1466             $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1467                                      qq{items\n\n});
1468         }
1469     } elsif ($o_type eq 'debug') {
1470         my(%valid);
1471         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1472         if (@o_what) {
1473             while (@o_what) {
1474                 my($what) = shift @o_what;
1475                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1476                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1477                     next;
1478                 }
1479                 if ( exists $CPAN::DEBUG{$what} ) {
1480                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1481                 } elsif ($what =~ /^\d/) {
1482                     $CPAN::DEBUG = $what;
1483                 } elsif (lc $what eq 'all') {
1484                     my($max) = 0;
1485                     for (values %CPAN::DEBUG) {
1486                         $max += $_;
1487                     }
1488                     $CPAN::DEBUG = $max;
1489                 } else {
1490                     my($known) = 0;
1491                     for (keys %CPAN::DEBUG) {
1492                         next unless lc($_) eq lc($what);
1493                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1494                         $known = 1;
1495                     }
1496                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1497                         unless $known;
1498                 }
1499             }
1500         } else {
1501           my $raw = "Valid options for debug are ".
1502               join(", ",sort(keys %CPAN::DEBUG), 'all').
1503                   qq{ or a number. Completion works on the options. }.
1504                       qq{Case is ignored.};
1505           require Text::Wrap;
1506           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1507           $CPAN::Frontend->myprint("\n\n");
1508         }
1509         if ($CPAN::DEBUG) {
1510             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1511             my($k,$v);
1512             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1513                 $v = $CPAN::DEBUG{$k};
1514                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1515                     if $v & $CPAN::DEBUG;
1516             }
1517         } else {
1518             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1519         }
1520     } else {
1521         $CPAN::Frontend->myprint(qq{
1522 Known options:
1523   conf    set or get configuration variables
1524   debug   set or get debugging options
1525 });
1526     }
1527 }
1528
1529 # CPAN::Shell::paintdots_onreload
1530 sub paintdots_onreload {
1531     my($ref) = shift;
1532     sub {
1533         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1534             my($subr) = $1;
1535             ++$$ref;
1536             local($|) = 1;
1537             # $CPAN::Frontend->myprint(".($subr)");
1538             $CPAN::Frontend->myprint(".");
1539             if ($subr =~ /\bshell\b/i) {
1540                 # warn "debug[$_[0]]";
1541
1542                 # It would be nice if we could detect that a
1543                 # subroutine has actually changed, but for now we
1544                 # practically always set the GOTOSHELL global
1545
1546                 $CPAN::GOTOSHELL=1;
1547             }
1548             return;
1549         }
1550         warn @_;
1551     };
1552 }
1553
1554 #-> sub CPAN::Shell::reload ;
1555 sub reload {
1556     my($self,$command,@arg) = @_;
1557     $command ||= "";
1558     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1559     if ($command =~ /^cpan$/i) {
1560         my $redef = 0;
1561         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1562         my $failed;
1563         my @relo = (
1564                     "CPAN.pm",
1565                     "CPAN/HandleConfig.pm",
1566                     "CPAN/FirstTime.pm",
1567                     "CPAN/Tarzip.pm",
1568                     "CPAN/Debug.pm",
1569                     "CPAN/Version.pm",
1570                     "CPAN/Queue.pm",
1571                     "CPAN/Reporter.pm",
1572                    );
1573       MFILE: for my $f (@relo) {
1574             next unless exists $INC{$f};
1575             my $p = $f;
1576             $p =~ s/\.pm$//;
1577             $p =~ s|/|::|g;
1578             $CPAN::Frontend->myprint("($p");
1579             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1580             $self->reload_this($f) or $failed++;
1581             my $v = eval "$p\::->VERSION";
1582             $CPAN::Frontend->myprint("v$v)");
1583         }
1584         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1585         if ($failed) {
1586             my $errors = $failed == 1 ? "error" : "errors";
1587             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
1588                                     "this session.\n");
1589         }
1590     } elsif ($command =~ /^index$/i) {
1591       CPAN::Index->force_reload;
1592     } else {
1593       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
1594 index    re-reads the index files\n});
1595     }
1596 }
1597
1598 # reload means only load again what we have loaded before
1599 #-> sub CPAN::Shell::reload_this ;
1600 sub reload_this {
1601     my($self,$f,$args) = @_;
1602     CPAN->debug("f[$f]") if $CPAN::DEBUG;
1603     return 1 unless $INC{$f}; # we never loaded this, so we do not
1604                               # reload but say OK
1605     my $pwd = CPAN::anycwd();
1606     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
1607     my($file);
1608     for my $inc (@INC) {
1609         $file = File::Spec->catfile($inc,split /\//, $f);
1610         last if -f $file;
1611         $file = "";
1612     }
1613     CPAN->debug("file[$file]") if $CPAN::DEBUG;
1614     my @inc = @INC;
1615     unless ($file && -f $file) {
1616         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
1617         $file = $INC{$f};
1618         @inc = substr($file,0,-length($f)); # bring in back to me!
1619     }
1620     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
1621     unless (-f $file) {
1622         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
1623         return;
1624     }
1625     my $mtime = (stat $file)[9];
1626     $reload->{$f} ||= $^T;
1627     my $must_reload = $mtime > $reload->{$f};
1628     $args ||= {};
1629     $must_reload ||= $args->{force};
1630     if ($must_reload) {
1631         my $fh = FileHandle->new($file) or
1632             $CPAN::Frontend->mydie("Could not open $file: $!");
1633         local($/);
1634         local $^W = 1;
1635         my $content = <$fh>;
1636         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
1637             if $CPAN::DEBUG;
1638         delete $INC{$f};
1639         local @INC = @inc;
1640         eval "require '$f'";
1641         if ($@){
1642             warn $@;
1643             return;
1644         }
1645         $reload->{$f} = time;
1646     } else {
1647         $CPAN::Frontend->myprint("__unchanged__");
1648     }
1649     return 1;
1650 }
1651
1652 #-> sub CPAN::Shell::mkmyconfig ;
1653 sub mkmyconfig {
1654     my($self, $cpanpm, %args) = @_;
1655     require CPAN::FirstTime;
1656     my $home = CPAN::HandleConfig::home;
1657     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
1658         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
1659     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
1660     CPAN::HandleConfig::require_myconfig_or_config;
1661     $CPAN::Config ||= {};
1662     $CPAN::Config = {
1663         %$CPAN::Config,
1664         build_dir           =>  undef,
1665         cpan_home           =>  undef,
1666         keep_source_where   =>  undef,
1667         histfile            =>  undef,
1668     };
1669     CPAN::FirstTime::init($cpanpm, %args);
1670 }
1671
1672 #-> sub CPAN::Shell::_binary_extensions ;
1673 sub _binary_extensions {
1674     my($self) = shift @_;
1675     my(@result,$module,%seen,%need,$headerdone);
1676     for $module ($self->expand('Module','/./')) {
1677         my $file  = $module->cpan_file;
1678         next if $file eq "N/A";
1679         next if $file =~ /^Contact Author/;
1680         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
1681         next if $dist->isa_perl;
1682         next unless $module->xs_file;
1683         local($|) = 1;
1684         $CPAN::Frontend->myprint(".");
1685         push @result, $module;
1686     }
1687 #    print join " | ", @result;
1688     $CPAN::Frontend->myprint("\n");
1689     return @result;
1690 }
1691
1692 #-> sub CPAN::Shell::recompile ;
1693 sub recompile {
1694     my($self) = shift @_;
1695     my($module,@module,$cpan_file,%dist);
1696     @module = $self->_binary_extensions();
1697     for $module (@module){  # we force now and compile later, so we
1698                             # don't do it twice
1699         $cpan_file = $module->cpan_file;
1700         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1701         $pack->force;
1702         $dist{$cpan_file}++;
1703     }
1704     for $cpan_file (sort keys %dist) {
1705         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
1706         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
1707         $pack->install;
1708         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
1709                            # stop a package from recompiling,
1710                            # e.g. IO-1.12 when we have perl5.003_10
1711     }
1712 }
1713
1714 #-> sub CPAN::Shell::scripts ;
1715 sub scripts {
1716     my($self, $arg) = @_;
1717     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
1718
1719     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
1720         unless ($CPAN::META->has_inst($req)) {
1721             $CPAN::Frontend->mywarn("  $req not available\n");
1722         }
1723     }
1724     my $p = HTML::LinkExtor->new();
1725     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
1726     unless (-f $indexfile) {
1727         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
1728     }
1729     $p->parse_file($indexfile);
1730     my @hrefs;
1731     my $qrarg;
1732     if ($arg =~ s|^/(.+)/$|$1|) {
1733         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
1734     }
1735     for my $l ($p->links) {
1736         my $tag = shift @$l;
1737         next unless $tag eq "a";
1738         my %att = @$l;
1739         my $href = $att{href};
1740         next unless $href =~ s|^\.\./authors/id/./../||;
1741         if ($arg) {
1742             if ($qrarg) {
1743                 if ($href =~ $qrarg) {
1744                     push @hrefs, $href;
1745                 }
1746             } else {
1747                 if ($href =~ /\Q$arg\E/) {
1748                     push @hrefs, $href;
1749                 }
1750             }
1751         } else {
1752             push @hrefs, $href;
1753         }
1754     }
1755     # now filter for the latest version if there is more than one of a name
1756     my %stems;
1757     for (sort @hrefs) {
1758         my $href = $_;
1759         s/-v?\d.*//;
1760         my $stem = $_;
1761         $stems{$stem} ||= [];
1762         push @{$stems{$stem}}, $href;
1763     }
1764     for (sort keys %stems) {
1765         my $highest;
1766         if (@{$stems{$_}} > 1) {
1767             $highest = List::Util::reduce {
1768                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
1769               } @{$stems{$_}};
1770         } else {
1771             $highest = $stems{$_}[0];
1772         }
1773         $CPAN::Frontend->myprint("$highest\n");
1774     }
1775 }
1776
1777 #-> sub CPAN::Shell::upgrade ;
1778 sub upgrade {
1779     my($self,@args) = @_;
1780     $self->install($self->r(@args));
1781 }
1782
1783 #-> sub CPAN::Shell::_u_r_common ;
1784 sub _u_r_common {
1785     my($self) = shift @_;
1786     my($what) = shift @_;
1787     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
1788     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
1789           $what && $what =~ /^[aru]$/;
1790     my(@args) = @_;
1791     @args = '/./' unless @args;
1792     my(@result,$module,%seen,%need,$headerdone,
1793        $version_undefs,$version_zeroes);
1794     $version_undefs = $version_zeroes = 0;
1795     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
1796     my @expand = $self->expand('Module',@args);
1797     my $expand = scalar @expand;
1798     if (0) { # Looks like noise to me, was very useful for debugging
1799              # for metadata cache
1800         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
1801     }
1802   MODULE: for $module (@expand) {
1803         my $file  = $module->cpan_file;
1804         next MODULE unless defined $file; # ??
1805         $file =~ s|^./../||;
1806         my($latest) = $module->cpan_version;
1807         my($inst_file) = $module->inst_file;
1808         my($have);
1809         return if $CPAN::Signal;
1810         if ($inst_file){
1811             if ($what eq "a") {
1812                 $have = $module->inst_version;
1813             } elsif ($what eq "r") {
1814                 $have = $module->inst_version;
1815                 local($^W) = 0;
1816                 if ($have eq "undef"){
1817                     $version_undefs++;
1818                 } elsif ($have == 0){
1819                     $version_zeroes++;
1820                 }
1821                 next MODULE unless CPAN::Version->vgt($latest, $have);
1822 # to be pedantic we should probably say:
1823 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
1824 # to catch the case where CPAN has a version 0 and we have a version undef
1825             } elsif ($what eq "u") {
1826                 next MODULE;
1827             }
1828         } else {
1829             if ($what eq "a") {
1830                 next MODULE;
1831             } elsif ($what eq "r") {
1832                 next MODULE;
1833             } elsif ($what eq "u") {
1834                 $have = "-";
1835             }
1836         }
1837         return if $CPAN::Signal; # this is sometimes lengthy
1838         $seen{$file} ||= 0;
1839         if ($what eq "a") {
1840             push @result, sprintf "%s %s\n", $module->id, $have;
1841         } elsif ($what eq "r") {
1842             push @result, $module->id;
1843             next MODULE if $seen{$file}++;
1844         } elsif ($what eq "u") {
1845             push @result, $module->id;
1846             next MODULE if $seen{$file}++;
1847             next MODULE if $file =~ /^Contact/;
1848         }
1849         unless ($headerdone++){
1850             $CPAN::Frontend->myprint("\n");
1851             $CPAN::Frontend->myprint(sprintf(
1852                                              $sprintf,
1853                                              "",
1854                                              "Package namespace",
1855                                              "",
1856                                              "installed",
1857                                              "latest",
1858                                              "in CPAN file"
1859                                             ));
1860         }
1861         my $color_on = "";
1862         my $color_off = "";
1863         # $GLOBAL_AUTOLOAD_RECURSION = 12;
1864         if (
1865             $COLOR_REGISTERED
1866             &&
1867             $CPAN::META->has_inst("Term::ANSIColor")
1868             &&
1869             $module->description
1870            ) {
1871             $color_on = Term::ANSIColor::color("green");
1872             $color_off = Term::ANSIColor::color("reset");
1873         }
1874         $CPAN::Frontend->myprint(sprintf $sprintf,
1875                                  $color_on,
1876                                  $module->id,
1877                                  $color_off,
1878                                  $have,
1879                                  $latest,
1880                                  $file);
1881         $need{$module->id}++;
1882     }
1883     unless (%need) {
1884         if ($what eq "u") {
1885             $CPAN::Frontend->myprint("No modules found for @args\n");
1886         } elsif ($what eq "r") {
1887             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
1888         }
1889     }
1890     if ($what eq "r") {
1891         if ($version_zeroes) {
1892             my $s_has = $version_zeroes > 1 ? "s have" : " has";
1893             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
1894                 qq{a version number of 0\n});
1895         }
1896         if ($version_undefs) {
1897             my $s_has = $version_undefs > 1 ? "s have" : " has";
1898             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
1899                 qq{parseable version number\n});
1900         }
1901     }
1902     @result;
1903 }
1904
1905 #-> sub CPAN::Shell::r ;
1906 sub r {
1907     shift->_u_r_common("r",@_);
1908 }
1909
1910 #-> sub CPAN::Shell::u ;
1911 sub u {
1912     shift->_u_r_common("u",@_);
1913 }
1914
1915 #-> sub CPAN::Shell::failed ;
1916 sub failed {
1917     my($self,$only_id,$silent) = @_;
1918     my @failed;
1919   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
1920         my $failed = "";
1921       NAY: for my $nosayer (
1922                             "writemakefile",
1923                             "signature_verify",
1924                             "make",
1925                             "make_test",
1926                             "install",
1927                             "make_clean",
1928                            ) {
1929             next unless exists $d->{$nosayer};
1930             next unless (
1931                          $d->{$nosayer}->can("failed") ?
1932                          $d->{$nosayer}->failed :
1933                          $d->{$nosayer} =~ /^NO/
1934                         );
1935             next NAY if $only_id && $only_id != (
1936                                                  $d->{$nosayer}->can("commandid")
1937                                                  ?
1938                                                  $d->{$nosayer}->commandid
1939                                                  :
1940                                                  $CPAN::CurrentCommandId
1941                                                 );
1942             $failed = $nosayer;
1943             last;
1944         }
1945         next DIST unless $failed;
1946         my $id = $d->id;
1947         $id =~ s|^./../||;
1948         #$print .= sprintf(
1949         #                  "  %-45s: %s %s\n",
1950         push @failed,
1951             (
1952              $d->{$failed}->can("failed") ?
1953              [
1954               $d->{$failed}->commandid,
1955               $id,
1956               $failed,
1957               $d->{$failed}->text,
1958              ] :
1959              [
1960               1,
1961               $id,
1962               $failed,
1963               $d->{$failed},
1964              ]
1965             );
1966     }
1967     my $scope = $only_id ? "command" : "session";
1968     if (@failed) {
1969         my $print = join "",
1970             map { sprintf "  %-45s: %s %s\n", @$_[1,2,3] }
1971                 sort { $a->[0] <=> $b->[0] } @failed;
1972         $CPAN::Frontend->myprint("Failed during this $scope:\n$print");
1973     } elsif (!$only_id || !$silent) {
1974         $CPAN::Frontend->myprint("Nothing failed in this $scope\n");
1975     }
1976 }
1977
1978 # XXX intentionally undocumented because completely bogus, unportable,
1979 # useless, etc.
1980
1981 #-> sub CPAN::Shell::status ;
1982 sub status {
1983     my($self) = @_;
1984     require Devel::Size;
1985     my $ps = FileHandle->new;
1986     open $ps, "/proc/$$/status";
1987     my $vm = 0;
1988     while (<$ps>) {
1989         next unless /VmSize:\s+(\d+)/;
1990         $vm = $1;
1991         last;
1992     }
1993     $CPAN::Frontend->mywarn(sprintf(
1994                                     "%-27s %6d\n%-27s %6d\n",
1995                                     "vm",
1996                                     $vm,
1997                                     "CPAN::META",
1998                                     Devel::Size::total_size($CPAN::META)/1024,
1999                                    ));
2000     for my $k (sort keys %$CPAN::META) {
2001         next unless substr($k,0,4) eq "read";
2002         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2003         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2004             warn sprintf "  %-25s %6d (keys: %6d)\n",
2005                 $k2,
2006                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2007                           scalar keys %{$CPAN::META->{$k}{$k2}};
2008         }
2009     }
2010 }
2011
2012 #-> sub CPAN::Shell::autobundle ;
2013 sub autobundle {
2014     my($self) = shift;
2015     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2016     my(@bundle) = $self->_u_r_common("a",@_);
2017     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2018     File::Path::mkpath($todir);
2019     unless (-d $todir) {
2020         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2021         return;
2022     }
2023     my($y,$m,$d) =  (localtime)[5,4,3];
2024     $y+=1900;
2025     $m++;
2026     my($c) = 0;
2027     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2028     my($to) = File::Spec->catfile($todir,"$me.pm");
2029     while (-f $to) {
2030         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2031         $to = File::Spec->catfile($todir,"$me.pm");
2032     }
2033     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2034     $fh->print(
2035                "package Bundle::$me;\n\n",
2036                "\$VERSION = '0.01';\n\n",
2037                "1;\n\n",
2038                "__END__\n\n",
2039                "=head1 NAME\n\n",
2040                "Bundle::$me - Snapshot of installation on ",
2041                $Config::Config{'myhostname'},
2042                " on ",
2043                scalar(localtime),
2044                "\n\n=head1 SYNOPSIS\n\n",
2045                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2046                "=head1 CONTENTS\n\n",
2047                join("\n", @bundle),
2048                "\n\n=head1 CONFIGURATION\n\n",
2049                Config->myconfig,
2050                "\n\n=head1 AUTHOR\n\n",
2051                "This Bundle has been generated automatically ",
2052                "by the autobundle routine in CPAN.pm.\n",
2053               );
2054     $fh->close;
2055     $CPAN::Frontend->myprint("\nWrote bundle file
2056     $to\n\n");
2057 }
2058
2059 #-> sub CPAN::Shell::expandany ;
2060 sub expandany {
2061     my($self,$s) = @_;
2062     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2063     if ($s =~ m|/|) { # looks like a file
2064         $s = CPAN::Distribution->normalize($s);
2065         return $CPAN::META->instance('CPAN::Distribution',$s);
2066         # Distributions spring into existence, not expand
2067     } elsif ($s =~ m|^Bundle::|) {
2068         $self->local_bundles; # scanning so late for bundles seems
2069                               # both attractive and crumpy: always
2070                               # current state but easy to forget
2071                               # somewhere
2072         return $self->expand('Bundle',$s);
2073     } else {
2074         return $self->expand('Module',$s)
2075             if $CPAN::META->exists('CPAN::Module',$s);
2076     }
2077     return;
2078 }
2079
2080 #-> sub CPAN::Shell::expand ;
2081 sub expand {
2082     my $self = shift;
2083     my($type,@args) = @_;
2084     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2085     my $class = "CPAN::$type";
2086     my $methods = ['id'];
2087     for my $meth (qw(name)) {
2088         next if $] < 5.00303; # no "can"
2089         next unless $class->can($meth);
2090         push @$methods, $meth;
2091     }
2092     $self->expand_by_method($class,$methods,@args);
2093 }
2094
2095 sub expand_by_method {
2096     my $self = shift;
2097     my($class,$methods,@args) = @_;
2098     my($arg,@m);
2099     for $arg (@args) {
2100         my($regex,$command);
2101         if ($arg =~ m|^/(.*)/$|) {
2102             $regex = $1;
2103         } elsif ($arg =~ m/=/) {
2104             $command = 1;
2105         }
2106         my $obj;
2107         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2108                     $class,
2109                     defined $regex ? $regex : "UNDEFINED",
2110                     defined $command ? $command : "UNDEFINED",
2111                    ) if $CPAN::DEBUG;
2112         if (defined $regex) {
2113             for $obj (
2114                       $CPAN::META->all_objects($class)
2115                      ) {
2116                 unless ($obj->id){
2117                     # BUG, we got an empty object somewhere
2118                     require Data::Dumper;
2119                     CPAN->debug(sprintf(
2120                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2121                                         $obj,
2122                                         Data::Dumper::Dumper($obj)
2123                                        )) if $CPAN::DEBUG;
2124                     next;
2125                 }
2126                 for my $method (@$methods) {
2127                     my $match = eval {$obj->$method() =~ /$regex/i};
2128                     if ($@) {
2129                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2130                         $err ||= $@; # if we were too restrictive above
2131                         $CPAN::Frontend->mydie("$err\n");
2132                     } elsif ($match) {
2133                         push @m, $obj;
2134                         last;
2135                     }
2136                 }
2137             }
2138         } elsif ($command) {
2139             die "equal sign in command disabled (immature interface), ".
2140                 "you can set
2141  ! \$CPAN::Shell::ADVANCED_QUERY=1
2142 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2143 that may go away anytime.\n"
2144                     unless $ADVANCED_QUERY;
2145             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2146             my($matchcrit) = $criterion =~ m/^~(.+)/;
2147             for my $self (
2148                           sort
2149                           {$a->id cmp $b->id}
2150                           $CPAN::META->all_objects($class)
2151                          ) {
2152                 my $lhs = $self->$method() or next; # () for 5.00503
2153                 if ($matchcrit) {
2154                     push @m, $self if $lhs =~ m/$matchcrit/;
2155                 } else {
2156                     push @m, $self if $lhs eq $criterion;
2157                 }
2158             }
2159         } else {
2160             my($xarg) = $arg;
2161             if ( $class eq 'CPAN::Bundle' ) {
2162                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2163             } elsif ($class eq "CPAN::Distribution") {
2164                 $xarg = CPAN::Distribution->normalize($arg);
2165             } else {
2166                 $xarg =~ s/:+/::/g;
2167             }
2168             if ($CPAN::META->exists($class,$xarg)) {
2169                 $obj = $CPAN::META->instance($class,$xarg);
2170             } elsif ($CPAN::META->exists($class,$arg)) {
2171                 $obj = $CPAN::META->instance($class,$arg);
2172             } else {
2173                 next;
2174             }
2175             push @m, $obj;
2176         }
2177     }
2178     @m = sort {$a->id cmp $b->id} @m;
2179     if ( $CPAN::DEBUG ) {
2180         my $wantarray = wantarray;
2181         my $join_m = join ",", map {$_->id} @m;
2182         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2183     }
2184     return wantarray ? @m : $m[0];
2185 }
2186
2187 #-> sub CPAN::Shell::format_result ;
2188 sub format_result {
2189     my($self) = shift;
2190     my($type,@args) = @_;
2191     @args = '/./' unless @args;
2192     my(@result) = $self->expand($type,@args);
2193     my $result = @result == 1 ?
2194         $result[0]->as_string :
2195             @result == 0 ?
2196                 "No objects of type $type found for argument @args\n" :
2197                     join("",
2198                          (map {$_->as_glimpse} @result),
2199                          scalar @result, " items found\n",
2200                         );
2201     $result;
2202 }
2203
2204 #-> sub CPAN::Shell::report_fh ;
2205 {
2206     my $installation_report_fh;
2207     my $previously_noticed = 0;
2208
2209     sub report_fh {
2210         return $installation_report_fh if $installation_report_fh;
2211         if ($CPAN::META->has_inst("File::Temp")) {
2212             $installation_report_fh
2213                 = File::Temp->new(
2214                                   template => 'cpan_install_XXXX',
2215                                   suffix   => '.txt',
2216                                   unlink   => 0,
2217                                  );
2218         }
2219         unless ( $installation_report_fh ) {
2220             warn("Couldn't open installation report file; " .
2221                  "no report file will be generated."
2222                 ) unless $previously_noticed++;
2223         }
2224     }
2225 }
2226
2227
2228 # The only reason for this method is currently to have a reliable
2229 # debugging utility that reveals which output is going through which
2230 # channel. No, I don't like the colors ;-)
2231
2232 # to turn colordebugging on, write
2233 # cpan> o conf colorize_output 1
2234
2235 #-> sub CPAN::Shell::print_ornamented ;
2236 {
2237     my $print_ornamented_have_warned = 0;
2238     sub colorize_output {
2239         my $colorize_output = $CPAN::Config->{colorize_output};
2240         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2241             unless ($print_ornamented_have_warned++) {
2242                 # no myprint/mywarn within myprint/mywarn!
2243                 warn "Colorize_output is set to true but Term::ANSIColor is not
2244 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2245             }
2246             $colorize_output = 0;
2247         }
2248         return $colorize_output;
2249     }
2250 }
2251
2252
2253 sub print_ornamented {
2254     my($self,$what,$ornament) = @_;
2255     return unless defined $what;
2256
2257     local $| = 1; # Flush immediately
2258     if ( $CPAN::Be_Silent ) {
2259         print {report_fh()} $what;
2260         return;
2261     }
2262     my $swhat = "$what"; # stringify if it is an object
2263     if ($CPAN::Config->{term_is_latin}){
2264         # courtesy jhi:
2265         $swhat
2266             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2267     }
2268     if ($self->colorize_output) {
2269         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2270             # if you want to have this configurable, please file a bugreport
2271             $ornament = "black on_cyan";
2272         }
2273         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2274         if ($@) {
2275             print "Term::ANSIColor rejects color[$ornament]: $@\n
2276 Please choose a different color (Hint: try 'o conf init color.*')\n";
2277         }
2278         print $color_on,
2279             $swhat,
2280                 Term::ANSIColor::color("reset");
2281     } else {
2282         print $swhat;
2283     }
2284 }
2285
2286 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2287 # where to use what! I think, we send everything to STDOUT and use
2288 # print for normal/good news and warn for news that need more
2289 # attention. Yes, this is our working contract for now.
2290 sub myprint {
2291     my($self,$what) = @_;
2292
2293     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2294 }
2295
2296 sub myexit {
2297     my($self,$what) = @_;
2298     $self->myprint($what);
2299     exit;
2300 }
2301
2302 sub mywarn {
2303     my($self,$what) = @_;
2304     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2305 }
2306
2307 # only to be used for shell commands
2308 sub mydie {
2309     my($self,$what) = @_;
2310     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2311
2312     # If it is the shell, we want that the following die to be silent,
2313     # but if it is not the shell, we would need a 'die $what'. We need
2314     # to take care that only shell commands use mydie. Is this
2315     # possible?
2316
2317     die "\n";
2318 }
2319
2320 # sub CPAN::Shell::colorable_makemaker_prompt
2321 sub colorable_makemaker_prompt {
2322     my($foo,$bar) = @_;
2323     if (CPAN::Shell->colorize_output) {
2324         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2325         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2326         print $color_on;
2327     }
2328     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2329     if (CPAN::Shell->colorize_output) {
2330         print Term::ANSIColor::color('reset');
2331     }
2332     return $ans;
2333 }
2334
2335 # use this only for unrecoverable errors!
2336 sub unrecoverable_error {
2337     my($self,$what) = @_;
2338     my @lines = split /\n/, $what;
2339     my $longest = 0;
2340     for my $l (@lines) {
2341         $longest = length $l if length $l > $longest;
2342     }
2343     $longest = 62 if $longest > 62;
2344     for my $l (@lines) {
2345         if ($l =~ /^\s*$/){
2346             $l = "\n";
2347             next;
2348         }
2349         $l = "==> $l";
2350         if (length $l < 66) {
2351             $l = pack "A66 A*", $l, "<==";
2352         }
2353         $l .= "\n";
2354     }
2355     unshift @lines, "\n";
2356     $self->mydie(join "", @lines);
2357 }
2358
2359 sub mysleep {
2360     my($self, $sleep) = @_;
2361     sleep $sleep;
2362 }
2363
2364 sub setup_output {
2365     return if -t STDOUT;
2366     my $odef = select STDERR;
2367     $| = 1;
2368     select STDOUT;
2369     $| = 1;
2370     select $odef;
2371 }
2372
2373 #-> sub CPAN::Shell::rematein ;
2374 # RE-adme||MA-ke||TE-st||IN-stall
2375 sub rematein {
2376     my $self = shift;
2377     my($meth,@some) = @_;
2378     my @pragma;
2379     while($meth =~ /^(force|notest)$/) {
2380         push @pragma, $meth;
2381         $meth = shift @some or
2382             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2383                                    "cannot continue");
2384     }
2385     setup_output();
2386     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2387
2388     # Here is the place to set "test_count" on all involved parties to
2389     # 0. We then can pass this counter on to the involved
2390     # distributions and those can refuse to test if test_count > X. In
2391     # the first stab at it we could use a 1 for "X".
2392
2393     # But when do I reset the distributions to start with 0 again?
2394     # Jost suggested to have a random or cycling interaction ID that
2395     # we pass through. But the ID is something that is just left lying
2396     # around in addition to the counter, so I'd prefer to set the
2397     # counter to 0 now, and repeat at the end of the loop. But what
2398     # about dependencies? They appear later and are not reset, they
2399     # enter the queue but not its copy. How do they get a sensible
2400     # test_count?
2401
2402     # construct the queue
2403     my($s,@s,@qcopy);
2404   STHING: foreach $s (@some) {
2405         my $obj;
2406         if (ref $s) {
2407             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2408             $obj = $s;
2409         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2410         } elsif ($s =~ m|^/|) { # looks like a regexp
2411             $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2412                                     "not supported.\nRejecting argument '$s'\n");
2413             $CPAN::Frontend->mysleep(2);
2414             next;
2415         } elsif ($meth eq "ls") {
2416             $self->globls($s,\@pragma);
2417             next STHING;
2418         } else {
2419             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2420             $obj = CPAN::Shell->expandany($s);
2421         }
2422         if (0) {
2423         } elsif (ref $obj) {
2424             $obj->color_cmd_tmps(0,1);
2425             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2426             push @qcopy, $obj;
2427         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2428             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2429             if ($meth =~ /^(dump|ls)$/) {
2430                 $obj->$meth();
2431             } else {
2432                 $CPAN::Frontend->mywarn(
2433                                         join "",
2434                                         "Don't be silly, you can't $meth ",
2435                                         $obj->fullname,
2436                                         " ;-)\n"
2437                                        );
2438                 $CPAN::Frontend->mysleep(2);
2439             }
2440         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2441             CPAN::InfoObj->dump($s);
2442         } else {
2443             $CPAN::Frontend
2444                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2445                           qq{don't know what it is.
2446 Try the command
2447
2448     i /$s/
2449
2450 to find objects with matching identifiers.
2451 });
2452             $CPAN::Frontend->mysleep(2);
2453         }
2454     }
2455
2456     # queuerunner (please be warned: when I started to change the
2457     # queue to hold objects instead of names, I made one or two
2458     # mistakes and never found which. I reverted back instead)
2459     while (my $q = CPAN::Queue->first) {
2460         my $obj;
2461         my $s = $q->as_string;
2462         my $reqtype = $q->reqtype || "";
2463         $obj = CPAN::Shell->expandany($s);
2464         $obj->{reqtype} ||= "";
2465         CPAN->debug("obj-reqtype[$obj->{reqtype}]".
2466                     "q-reqtype[$reqtype]") if $CPAN::DEBUG;
2467         if ($obj->{reqtype}) {
2468             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
2469                 $obj->{reqtype} = $reqtype;
2470                 if (
2471                     exists $obj->{install}
2472                     &&
2473                     (
2474                      $obj->{install}->can("failed") ?
2475                      $obj->{install}->failed :
2476                      $obj->{install} =~ /^NO/
2477                     )
2478                    ) {
2479                     delete $obj->{install};
2480                     $CPAN::Frontend->mywarn
2481                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
2482                 }
2483             }
2484         } else {
2485             $obj->{reqtype} = $reqtype;
2486         }
2487
2488         for my $pragma (@pragma) {
2489             if ($pragma
2490                 &&
2491                 ($] < 5.00303 || $obj->can($pragma))){
2492                 ### compatibility with 5.003
2493                 $obj->$pragma($meth); # the pragma "force" in
2494                                       # "CPAN::Distribution" must know
2495                                       # what we are intending
2496             }
2497         }
2498         if ($]>=5.00303 && $obj->can('called_for')) {
2499             $obj->called_for($s);
2500         }
2501         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
2502                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
2503
2504         push @qcopy, $obj;
2505         if ($obj->$meth()){
2506             CPAN::Queue->delete($s);
2507         } else {
2508             CPAN->debug("failed");
2509         }
2510
2511         $obj->undelay;
2512         CPAN::Queue->delete_first($s);
2513     }
2514     for my $obj (@qcopy) {
2515         $obj->color_cmd_tmps(0,0);
2516     }
2517 }
2518
2519 #-> sub CPAN::Shell::recent ;
2520 sub recent {
2521   my($self) = @_;
2522
2523   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
2524   return;
2525 }
2526
2527 {
2528     # set up the dispatching methods
2529     no strict "refs";
2530     for my $command (qw(
2531                         clean
2532                         cvs_import
2533                         dump
2534                         force
2535                         get
2536                         install
2537                         look
2538                         ls
2539                         make
2540                         notest
2541                         perldoc
2542                         readme
2543                         test
2544                        )) {
2545         *$command = sub { shift->rematein($command, @_); };
2546     }
2547 }
2548
2549 package CPAN::LWP::UserAgent;
2550 use strict;
2551
2552 sub config {
2553     return if $SETUPDONE;
2554     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2555         require LWP::UserAgent;
2556         @ISA = qw(Exporter LWP::UserAgent);
2557         $SETUPDONE++;
2558     } else {
2559         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
2560     }
2561 }
2562
2563 sub get_basic_credentials {
2564     my($self, $realm, $uri, $proxy) = @_;
2565     if ($USER && $PASSWD) {
2566         return ($USER, $PASSWD);
2567     }
2568     if ( $proxy ) {
2569         ($USER,$PASSWD) = $self->get_proxy_credentials();
2570     } else {
2571         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
2572     }
2573     return($USER,$PASSWD);
2574 }
2575
2576 sub get_proxy_credentials {
2577     my $self = shift;
2578     my ($user, $password);
2579     if ( defined $CPAN::Config->{proxy_user} &&
2580          defined $CPAN::Config->{proxy_pass}) {
2581         $user = $CPAN::Config->{proxy_user};
2582         $password = $CPAN::Config->{proxy_pass};
2583         return ($user, $password);
2584     }
2585     my $username_prompt = "\nProxy authentication needed!
2586  (Note: to permanently configure username and password run
2587    o conf proxy_user your_username
2588    o conf proxy_pass your_password
2589      )\nUsername:";
2590     ($user, $password) =
2591         _get_username_and_password_from_user($username_prompt);
2592     return ($user,$password);
2593 }
2594
2595 sub get_non_proxy_credentials {
2596     my $self = shift;
2597     my ($user,$password);
2598     if ( defined $CPAN::Config->{username} &&
2599          defined $CPAN::Config->{password}) {
2600         $user = $CPAN::Config->{username};
2601         $password = $CPAN::Config->{password};
2602         return ($user, $password);
2603     }
2604     my $username_prompt = "\nAuthentication needed!
2605      (Note: to permanently configure username and password run
2606        o conf username your_username
2607        o conf password your_password
2608      )\nUsername:";
2609
2610     ($user, $password) =
2611         _get_username_and_password_from_user($username_prompt);
2612     return ($user,$password);
2613 }
2614
2615 sub _get_username_and_password_from_user {
2616     my $self = shift;
2617     my $username_message = shift;
2618     my ($username,$password);
2619
2620     ExtUtils::MakeMaker->import(qw(prompt));
2621     $username = prompt($username_message);
2622         if ($CPAN::META->has_inst("Term::ReadKey")) {
2623             Term::ReadKey::ReadMode("noecho");
2624         }
2625     else {
2626         $CPAN::Frontend->mywarn(
2627             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
2628         );
2629     }
2630     $password = prompt("Password:");
2631
2632         if ($CPAN::META->has_inst("Term::ReadKey")) {
2633             Term::ReadKey::ReadMode("restore");
2634         }
2635         $CPAN::Frontend->myprint("\n\n");
2636     return ($username,$password);
2637 }
2638
2639 # mirror(): Its purpose is to deal with proxy authentication. When we
2640 # call SUPER::mirror, we relly call the mirror method in
2641 # LWP::UserAgent. LWP::UserAgent will then call
2642 # $self->get_basic_credentials or some equivalent and this will be
2643 # $self->dispatched to our own get_basic_credentials method.
2644
2645 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2646
2647 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2648 # although we have gone through our get_basic_credentials, the proxy
2649 # server refuses to connect. This could be a case where the username or
2650 # password has changed in the meantime, so I'm trying once again without
2651 # $USER and $PASSWD to give the get_basic_credentials routine another
2652 # chance to set $USER and $PASSWD.
2653
2654 # mirror(): Its purpose is to deal with proxy authentication. When we
2655 # call SUPER::mirror, we relly call the mirror method in
2656 # LWP::UserAgent. LWP::UserAgent will then call
2657 # $self->get_basic_credentials or some equivalent and this will be
2658 # $self->dispatched to our own get_basic_credentials method.
2659
2660 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
2661
2662 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
2663 # although we have gone through our get_basic_credentials, the proxy
2664 # server refuses to connect. This could be a case where the username or
2665 # password has changed in the meantime, so I'm trying once again without
2666 # $USER and $PASSWD to give the get_basic_credentials routine another
2667 # chance to set $USER and $PASSWD.
2668
2669 sub mirror {
2670     my($self,$url,$aslocal) = @_;
2671     my $result = $self->SUPER::mirror($url,$aslocal);
2672     if ($result->code == 407) {
2673         undef $USER;
2674         undef $PASSWD;
2675         $result = $self->SUPER::mirror($url,$aslocal);
2676     }
2677     $result;
2678 }
2679
2680 package CPAN::FTP;
2681 use strict;
2682
2683 #-> sub CPAN::FTP::ftp_get ;
2684 sub ftp_get {
2685     my($class,$host,$dir,$file,$target) = @_;
2686     $class->debug(
2687                   qq[Going to fetch file [$file] from dir [$dir]
2688         on host [$host] as local [$target]\n]
2689                  ) if $CPAN::DEBUG;
2690     my $ftp = Net::FTP->new($host);
2691     unless ($ftp) {
2692         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
2693         return;
2694     }
2695     return 0 unless defined $ftp;
2696     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
2697     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
2698     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
2699         my $msg = $ftp->message;
2700         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
2701         return;
2702     }
2703     unless ( $ftp->cwd($dir) ){
2704         my $msg = $ftp->message;
2705         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
2706         return;
2707     }
2708     $ftp->binary;
2709     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
2710     unless ( $ftp->get($file,$target) ){
2711         my $msg = $ftp->message;
2712         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
2713         return;
2714     }
2715     $ftp->quit; # it's ok if this fails
2716     return 1;
2717 }
2718
2719 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
2720
2721  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
2722  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
2723  # > ***************
2724  # > *** 1562,1567 ****
2725  # > --- 1562,1580 ----
2726  # >       return 1 if substr($url,0,4) eq "file";
2727  # >       return 1 unless $url =~ m|://([^/]+)|;
2728  # >       my $host = $1;
2729  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
2730  # > +     if ($proxy) {
2731  # > +         $proxy =~ m|://([^/:]+)|;
2732  # > +         $proxy = $1;
2733  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
2734  # > +         if ($noproxy) {
2735  # > +             if ($host !~ /$noproxy$/) {
2736  # > +                 $host = $proxy;
2737  # > +             }
2738  # > +         } else {
2739  # > +             $host = $proxy;
2740  # > +         }
2741  # > +     }
2742  # >       require Net::Ping;
2743  # >       return 1 unless $Net::Ping::VERSION >= 2;
2744  # >       my $p;
2745
2746
2747 #-> sub CPAN::FTP::localize ;
2748 sub localize {
2749     my($self,$file,$aslocal,$force) = @_;
2750     $force ||= 0;
2751     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
2752         unless defined $aslocal;
2753     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
2754         if $CPAN::DEBUG;
2755
2756     if ($^O eq 'MacOS') {
2757         # Comment by AK on 2000-09-03: Uniq short filenames would be
2758         # available in CHECKSUMS file
2759         my($name, $path) = File::Basename::fileparse($aslocal, '');
2760         if (length($name) > 31) {
2761             $name =~ s/(
2762                         \.(
2763                            readme(\.(gz|Z))? |
2764                            (tar\.)?(gz|Z) |
2765                            tgz |
2766                            zip |
2767                            pm\.(gz|Z)
2768                           )
2769                        )$//x;
2770             my $suf = $1;
2771             my $size = 31 - length($suf);
2772             while (length($name) > $size) {
2773                 chop $name;
2774             }
2775             $name .= $suf;
2776             $aslocal = File::Spec->catfile($path, $name);
2777         }
2778     }
2779
2780     if (-f $aslocal && -r _ && !($force & 1)){
2781         my $size;
2782         if ($size = -s $aslocal) {
2783             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
2784             return $aslocal;
2785         } else {
2786             # empty file from a previous unsuccessful attempt to download it
2787             unlink $aslocal or
2788                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
2789                                        "could not remove.");
2790         }
2791     }
2792     my($restore) = 0;
2793     if (-f $aslocal){
2794         rename $aslocal, "$aslocal.bak";
2795         $restore++;
2796     }
2797
2798     my($aslocal_dir) = File::Basename::dirname($aslocal);
2799     File::Path::mkpath($aslocal_dir);
2800     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
2801         qq{directory "$aslocal_dir".
2802     I\'ll continue, but if you encounter problems, they may be due
2803     to insufficient permissions.\n}) unless -w $aslocal_dir;
2804
2805     # Inheritance is not easier to manage than a few if/else branches
2806     if ($CPAN::META->has_usable('LWP::UserAgent')) {
2807         unless ($Ua) {
2808             CPAN::LWP::UserAgent->config;
2809             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
2810             if ($@) {
2811                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
2812                     if $CPAN::DEBUG;
2813             } else {
2814                 my($var);
2815                 $Ua->proxy('ftp',  $var)
2816                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
2817                 $Ua->proxy('http', $var)
2818                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
2819
2820
2821 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
2822
2823 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
2824 #  > use ones that require basic autorization.
2825 #  
2826 #  > Example of when I use it manually in my own stuff:
2827 #  
2828 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
2829 #  > $req->proxy_authorization_basic("username","password");
2830 #  > $res = $ua->request($req);
2831
2832
2833                 $Ua->no_proxy($var)
2834                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
2835             }
2836         }
2837     }
2838     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
2839         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
2840     }
2841
2842     # Try the list of urls for each single object. We keep a record
2843     # where we did get a file from
2844     my(@reordered,$last);
2845     $CPAN::Config->{urllist} ||= [];
2846     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
2847         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
2848         $CPAN::Config->{urllist} = [];
2849     }
2850     $last = $#{$CPAN::Config->{urllist}};
2851     if ($force & 2) { # local cpans probably out of date, don't reorder
2852         @reordered = (0..$last);
2853     } else {
2854         @reordered =
2855             sort {
2856                 (substr($CPAN::Config->{urllist}[$b],0,4) eq "file")
2857                     <=>
2858                 (substr($CPAN::Config->{urllist}[$a],0,4) eq "file")
2859                     or
2860                 defined($ThesiteURL)
2861                     and
2862                 ($CPAN::Config->{urllist}[$b] eq $ThesiteURL)
2863                     <=>
2864                 ($CPAN::Config->{urllist}[$a] eq $ThesiteURL)
2865             } 0..$last;
2866     }
2867     my(@levels);
2868     $Themethod ||= "";
2869     $self->debug("Themethod[$Themethod]") if $CPAN::DEBUG;
2870     if ($Themethod) {
2871         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
2872     } else {
2873         @levels = qw/easy hard hardest/;
2874     }
2875     @levels = qw/easy/ if $^O eq 'MacOS';
2876     my($levelno);
2877     local $ENV{FTP_PASSIVE} = 
2878         exists $CPAN::Config->{ftp_passive} ?
2879         $CPAN::Config->{ftp_passive} : 1;
2880     for $levelno (0..$#levels) {
2881         my $level = $levels[$levelno];
2882         my $method = "host$level";
2883         my @host_seq = $level eq "easy" ?
2884             @reordered : 0..$last;  # reordered has CDROM up front
2885         my @urllist = map { $CPAN::Config->{urllist}[$_] } @host_seq;
2886         for my $u (@urllist) {
2887             if ($u->can("text")) {
2888                 $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
2889             } else {
2890                 $u .= "/" unless substr($u,-1) eq "/";
2891                 $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
2892             }
2893         }
2894         for my $u (@CPAN::Defaultsites) {
2895             push @urllist, $u unless grep { $_ eq $u } @urllist;
2896         }
2897         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
2898         my $ret = $self->$method(\@urllist,$file,$aslocal);
2899         if ($ret) {
2900           $Themethod = $level;
2901           my $now = time;
2902           # utime $now, $now, $aslocal; # too bad, if we do that, we
2903                                       # might alter a local mirror
2904           $self->debug("level[$level]") if $CPAN::DEBUG;
2905           return $ret;
2906         } else {
2907           unlink $aslocal;
2908           last if $CPAN::Signal; # need to cleanup
2909         }
2910     }
2911     unless ($CPAN::Signal) {
2912         my(@mess);
2913         local $" = " ";
2914         if (@{$CPAN::Config->{urllist}}) {
2915             push @mess,
2916                 qq{Please check, if the URLs I found in your configuration file \(}.
2917                     join(", ", @{$CPAN::Config->{urllist}}).
2918                         qq{\) are valid.};
2919         } else {
2920             push @mess, qq{Your urllist is empty!};
2921         }
2922         push @mess, qq{The urllist can be edited.},
2923             qq{E.g. with 'o conf urllist push ftp://myurl/'};
2924         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
2925         $CPAN::Frontend->mywarn("Could not fetch $file\n");
2926         $CPAN::Frontend->mysleep(2);
2927     }
2928     if ($restore) {
2929         rename "$aslocal.bak", $aslocal;
2930         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
2931                                  $self->ls($aslocal));
2932         return $aslocal;
2933     }
2934     return;
2935 }
2936
2937 # package CPAN::FTP;
2938 sub hosteasy {
2939     my($self,$host_seq,$file,$aslocal) = @_;
2940     my($ro_url);
2941   HOSTEASY: for $ro_url (@$host_seq) {
2942         my $url .= "$ro_url$file";
2943         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
2944         if ($url =~ /^file:/) {
2945             my $l;
2946             if ($CPAN::META->has_inst('URI::URL')) {
2947                 my $u =  URI::URL->new($url);
2948                 $l = $u->path;
2949             } else { # works only on Unix, is poorly constructed, but
2950                 # hopefully better than nothing.
2951                 # RFC 1738 says fileurl BNF is
2952                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
2953                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
2954                 # the code
2955                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
2956                 $l =~ s|^file:||;                   # assume they
2957                                                     # meant
2958                                                     # file://localhost
2959                 $l =~ s|^/||s
2960                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
2961             }
2962             $self->debug("local file[$l]") if $CPAN::DEBUG;
2963             if ( -f $l && -r _) {
2964                 $ThesiteURL = $ro_url;
2965                 return $l;
2966             }
2967             if ($l =~ /(.+)\.gz$/) {
2968                 my $ungz = $1;
2969                 if ( -f $ungz && -r _) {
2970                     $ThesiteURL = $ro_url;
2971                     return $ungz;
2972                 }
2973             }
2974             # Maybe mirror has compressed it?
2975             if (-f "$l.gz") {
2976                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
2977                 CPAN::Tarzip->new("$l.gz")->gunzip($aslocal);
2978                 if ( -f $aslocal) {
2979                     $ThesiteURL = $ro_url;
2980                     return $aslocal;
2981                 }
2982             }
2983         }
2984         if ($CPAN::META->has_usable('LWP')) {
2985             $CPAN::Frontend->myprint("Fetching with LWP:
2986   $url
2987 ");
2988             unless ($Ua) {
2989                 CPAN::LWP::UserAgent->config;
2990                 eval { $Ua = CPAN::LWP::UserAgent->new; };
2991                 if ($@) {
2992                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
2993                 }
2994             }
2995             my $res = $Ua->mirror($url, $aslocal);
2996             if ($res->is_success) {
2997                 $ThesiteURL = $ro_url;
2998                 my $now = time;
2999                 utime $now, $now, $aslocal; # download time is more
3000                                             # important than upload
3001                                             # time
3002                 return $aslocal;
3003             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3004                 my $gzurl = "$url.gz";
3005                 $CPAN::Frontend->myprint("Fetching with LWP:
3006   $gzurl
3007 ");
3008                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3009                 if ($res->is_success &&
3010                     CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)
3011                    ) {
3012                     $ThesiteURL = $ro_url;
3013                     return $aslocal;
3014                 }
3015             } else {
3016                 $CPAN::Frontend->myprint(sprintf(
3017                                                  "LWP failed with code[%s] message[%s]\n",
3018                                                  $res->code,
3019                                                  $res->message,
3020                                                 ));
3021                 # Alan Burlison informed me that in firewall environments
3022                 # Net::FTP can still succeed where LWP fails. So we do not
3023                 # skip Net::FTP anymore when LWP is available.
3024             }
3025         } elsif (
3026                  $ro_url->can("text")
3027                  and
3028                  $ro_url->{FROM} eq "USER"
3029                 ){
3030             my $ret = $self->hosthard([$ro_url],$file,$aslocal);
3031             return $ret if $ret;
3032         } else {
3033             $CPAN::Frontend->mywarn("  LWP not available\n");
3034         }
3035         return if $CPAN::Signal;
3036         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3037             # that's the nice and easy way thanks to Graham
3038             my($host,$dir,$getfile) = ($1,$2,$3);
3039             if ($CPAN::META->has_usable('Net::FTP')) {
3040                 $dir =~ s|/+|/|g;
3041                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3042   $url
3043 ");
3044                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3045                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3046                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3047                     $ThesiteURL = $ro_url;
3048                     return $aslocal;
3049                 }
3050                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3051                     my $gz = "$aslocal.gz";
3052                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3053   $url.gz
3054 ");
3055                     if (CPAN::FTP->ftp_get($host,
3056                                            $dir,
3057                                            "$getfile.gz",
3058                                            $gz) &&
3059                         CPAN::Tarzip->new($gz)->gunzip($aslocal)
3060                        ){
3061                         $ThesiteURL = $ro_url;
3062                         return $aslocal;
3063                     }
3064                 }
3065                 # next HOSTEASY;
3066             }
3067         }
3068         return if $CPAN::Signal;
3069     }
3070 }
3071
3072 # package CPAN::FTP;
3073 sub hosthard {
3074   my($self,$host_seq,$file,$aslocal) = @_;
3075
3076   # Came back if Net::FTP couldn't establish connection (or
3077   # failed otherwise) Maybe they are behind a firewall, but they
3078   # gave us a socksified (or other) ftp program...
3079
3080   my($ro_url);
3081   my($devnull) = $CPAN::Config->{devnull} || "";
3082   # < /dev/null ";
3083   my($aslocal_dir) = File::Basename::dirname($aslocal);
3084   File::Path::mkpath($aslocal_dir);
3085   HOSTHARD: for $ro_url (@$host_seq) {
3086         my $url = "$ro_url$file";
3087         my($proto,$host,$dir,$getfile);
3088
3089         # Courtesy Mark Conty mark_conty@cargill.com change from
3090         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3091         # to
3092         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3093           # proto not yet used
3094           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3095         } else {
3096           next HOSTHARD; # who said, we could ftp anything except ftp?
3097         }
3098         next HOSTHARD if $proto eq "file"; # file URLs would have had
3099                                            # success above. Likely a bogus URL
3100
3101         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3102
3103         # Try the most capable first and leave ncftp* for last as it only 
3104         # does FTP.
3105       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3106           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3107           next unless defined $funkyftp;
3108           next if $funkyftp =~ /^\s*$/;
3109
3110           my($asl_ungz, $asl_gz);
3111           ($asl_ungz = $aslocal) =~ s/\.gz//;
3112           $asl_gz = "$asl_ungz.gz";
3113
3114           my($src_switch) = "";
3115           my($chdir) = "";
3116           my($stdout_redir) = " > $asl_ungz";
3117           if ($f eq "lynx"){
3118             $src_switch = " -source";
3119           } elsif ($f eq "ncftp"){
3120             $src_switch = " -c";
3121           } elsif ($f eq "wget"){
3122             $src_switch = " -O $asl_ungz";
3123             $stdout_redir = "";
3124           } elsif ($f eq 'curl'){
3125             $src_switch = ' -L -f -s -S --netrc-optional';
3126           }
3127
3128           if ($f eq "ncftpget"){
3129             $chdir = "cd $aslocal_dir && ";
3130             $stdout_redir = "";
3131           }
3132           $CPAN::Frontend->myprint(
3133                                    qq[
3134 Trying with "$funkyftp$src_switch" to get
3135     $url
3136 ]);
3137           my($system) =
3138               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3139           $self->debug("system[$system]") if $CPAN::DEBUG;
3140           my($wstatus) = system($system);
3141           if ($f eq "lynx") {
3142               # lynx returns 0 when it fails somewhere
3143               if (-s $asl_ungz) {
3144                   my $content = do { local *FH; open FH, $asl_ungz or die; local $/; <FH> };
3145                   if ($content =~ /^<.*<title>[45]/si) {
3146                       $CPAN::Frontend->mywarn(qq{
3147 No success, the file that lynx has has downloaded looks like an error message:
3148 $content
3149 });
3150                       $CPAN::Frontend->mysleep(1);
3151                       next DLPRG;
3152                   }
3153               } else {
3154                   $CPAN::Frontend->myprint(qq{
3155 No success, the file that lynx has has downloaded is an empty file.
3156 });
3157                   next DLPRG;
3158               }
3159           }
3160           if ($wstatus == 0) {
3161             if (-s $aslocal) {
3162               # Looks good
3163             } elsif ($asl_ungz ne $aslocal) {
3164               # test gzip integrity
3165               if (CPAN::Tarzip->new($asl_ungz)->gtest) {
3166                   # e.g. foo.tar is gzipped --> foo.tar.gz
3167                   rename $asl_ungz, $aslocal;
3168               } else {
3169                   CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz);
3170               }
3171             }
3172             $ThesiteURL = $ro_url;
3173             return $aslocal;
3174           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3175             unlink $asl_ungz if
3176                 -f $asl_ungz && -s _ == 0;
3177             my $gz = "$aslocal.gz";
3178             my $gzurl = "$url.gz";
3179             $CPAN::Frontend->myprint(
3180                                      qq[
3181 Trying with "$funkyftp$src_switch" to get
3182   $url.gz
3183 ]);
3184             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3185             $self->debug("system[$system]") if $CPAN::DEBUG;
3186             my($wstatus);
3187             if (($wstatus = system($system)) == 0
3188                 &&
3189                 -s $asl_gz
3190                ) {
3191               # test gzip integrity
3192               my $ct = CPAN::Tarzip->new($asl_gz);
3193               if ($ct->gtest) {
3194                   $ct->gunzip($aslocal);
3195               } else {
3196                   # somebody uncompressed file for us?
3197                   rename $asl_ungz, $aslocal;
3198               }
3199               $ThesiteURL = $ro_url;
3200               return $aslocal;
3201             } else {
3202               unlink $asl_gz if -f $asl_gz;
3203             }
3204           } else {
3205             my $estatus = $wstatus >> 8;
3206             my $size = -f $aslocal ?
3207                 ", left\n$aslocal with size ".-s _ :
3208                     "\nWarning: expected file [$aslocal] doesn't exist";
3209             $CPAN::Frontend->myprint(qq{
3210 System call "$system"
3211 returned status $estatus (wstat $wstatus)$size
3212 });
3213           }
3214           return if $CPAN::Signal;
3215         } # transfer programs
3216     } # host
3217 }
3218
3219 # package CPAN::FTP;
3220 sub hosthardest {
3221     my($self,$host_seq,$file,$aslocal) = @_;
3222
3223     my($ro_url);
3224     my($aslocal_dir) = File::Basename::dirname($aslocal);
3225     File::Path::mkpath($aslocal_dir);
3226     my $ftpbin = $CPAN::Config->{ftp};
3227     unless (length $ftpbin && MM->maybe_command($ftpbin)) {
3228         $CPAN::Frontend->myprint("No external ftp command available\n\n");
3229         return;
3230     }
3231     $CPAN::Frontend->mywarn(qq{
3232 As a last ressort we now switch to the external ftp command '$ftpbin'
3233 to get '$aslocal'.
3234
3235 Doing so often leads to problems that are hard to diagnose.
3236
3237 If you're victim of such problems, please consider unsetting the ftp
3238 config variable with
3239
3240     o conf ftp ""
3241     o conf commit
3242
3243 });
3244     $CPAN::Frontend->mysleep(2);
3245   HOSTHARDEST: for $ro_url (@$host_seq) {
3246         my $url = "$ro_url$file";
3247         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
3248         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3249             next;
3250         }
3251         my($host,$dir,$getfile) = ($1,$2,$3);
3252         my $timestamp = 0;
3253         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
3254            $ctime,$blksize,$blocks) = stat($aslocal);
3255         $timestamp = $mtime ||= 0;
3256         my($netrc) = CPAN::FTP::netrc->new;
3257         my($netrcfile) = $netrc->netrc;
3258         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
3259         my $targetfile = File::Basename::basename($aslocal);
3260         my(@dialog);
3261         push(
3262              @dialog,
3263              "lcd $aslocal_dir",
3264              "cd /",
3265              map("cd $_", split /\//, $dir), # RFC 1738
3266              "bin",
3267              "get $getfile $targetfile",
3268              "quit"
3269             );
3270         if (! $netrcfile) {
3271             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
3272         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
3273             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
3274                                 $netrc->hasdefault,
3275                                 $netrc->contains($host))) if $CPAN::DEBUG;
3276             if ($netrc->protected) {
3277                 my $dialog = join "", map { "    $_\n" } @dialog;
3278                 my $netrc_explain;
3279                 if ($netrc->contains($host)) {
3280                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
3281                         "manages the login";
3282                 } else {
3283                     $netrc_explain = "Relying that your default .netrc entry ".
3284                         "manages the login";
3285                 }
3286                 $CPAN::Frontend->myprint(qq{
3287   Trying with external ftp to get
3288     $url
3289   $netrc_explain
3290   Going to send the dialog
3291 $dialog
3292 }
3293                      );
3294                 $self->talk_ftp("$ftpbin$verbose $host",
3295                                 @dialog);
3296                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3297                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3298                 $mtime ||= 0;
3299                 if ($mtime > $timestamp) {
3300                     $CPAN::Frontend->myprint("GOT $aslocal\n");
3301                     $ThesiteURL = $ro_url;
3302                     return $aslocal;
3303                 } else {
3304                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
3305                 }
3306                 return if $CPAN::Signal;
3307             } else {
3308                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
3309                                         qq{correctly protected.\n});
3310             }
3311         } else {
3312             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
3313   nor does it have a default entry\n");
3314         }
3315
3316         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
3317         # then and login manually to host, using e-mail as
3318         # password.
3319         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
3320         unshift(
3321                 @dialog,
3322                 "open $host",
3323                 "user anonymous $Config::Config{'cf_email'}"
3324                );
3325         my $dialog = join "", map { "    $_\n" } @dialog;
3326         $CPAN::Frontend->myprint(qq{
3327   Trying with external ftp to get
3328     $url
3329   Going to send the dialog
3330 $dialog
3331 }
3332                      );
3333         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
3334         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3335          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
3336         $mtime ||= 0;
3337         if ($mtime > $timestamp) {
3338             $CPAN::Frontend->myprint("GOT $aslocal\n");
3339             $ThesiteURL = $ro_url;
3340             return $aslocal;
3341         } else {
3342             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
3343         }
3344         return if $CPAN::Signal;
3345         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
3346         $CPAN::Frontend->mysleep(2);
3347     } # host
3348 }
3349
3350 # package CPAN::FTP;
3351 sub talk_ftp {
3352     my($self,$command,@dialog) = @_;
3353     my $fh = FileHandle->new;
3354     $fh->open("|$command") or die "Couldn't open ftp: $!";
3355     foreach (@dialog) { $fh->print("$_\n") }
3356     $fh->close;         # Wait for process to complete
3357     my $wstatus = $?;
3358     my $estatus = $wstatus >> 8;
3359     $CPAN::Frontend->myprint(qq{
3360 Subprocess "|$command"
3361   returned status $estatus (wstat $wstatus)
3362 }) if $wstatus;
3363 }
3364
3365 # find2perl needs modularization, too, all the following is stolen
3366 # from there
3367 # CPAN::FTP::ls
3368 sub ls {
3369     my($self,$name) = @_;
3370     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
3371      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
3372
3373     my($perms,%user,%group);
3374     my $pname = $name;
3375
3376     if ($blocks) {
3377         $blocks = int(($blocks + 1) / 2);
3378     }
3379     else {
3380         $blocks = int(($sizemm + 1023) / 1024);
3381     }
3382
3383     if    (-f _) { $perms = '-'; }
3384     elsif (-d _) { $perms = 'd'; }
3385     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
3386     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
3387     elsif (-p _) { $perms = 'p'; }
3388     elsif (-S _) { $perms = 's'; }
3389     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
3390
3391     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
3392     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
3393     my $tmpmode = $mode;
3394     my $tmp = $rwx[$tmpmode & 7];
3395     $tmpmode >>= 3;
3396     $tmp = $rwx[$tmpmode & 7] . $tmp;
3397     $tmpmode >>= 3;
3398     $tmp = $rwx[$tmpmode & 7] . $tmp;
3399     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
3400     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
3401     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
3402     $perms .= $tmp;
3403
3404     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
3405     my $group = $group{$gid} || $gid;
3406
3407     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
3408     my($timeyear);
3409     my($moname) = $moname[$mon];
3410     if (-M _ > 365.25 / 2) {
3411         $timeyear = $year + 1900;
3412     }
3413     else {
3414         $timeyear = sprintf("%02d:%02d", $hour, $min);
3415     }
3416
3417     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
3418             $ino,
3419                  $blocks,
3420                       $perms,
3421                             $nlink,
3422                                 $user,
3423                                      $group,
3424                                           $sizemm,
3425                                               $moname,
3426                                                  $mday,
3427                                                      $timeyear,
3428                                                          $pname;
3429 }
3430
3431 package CPAN::FTP::netrc;
3432 use strict;
3433
3434 # package CPAN::FTP::netrc;
3435 sub new {
3436     my($class) = @_;
3437     my $home = CPAN::HandleConfig::home;
3438     my $file = File::Spec->catfile($home,".netrc");
3439
3440     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
3441        $atime,$mtime,$ctime,$blksize,$blocks)
3442         = stat($file);
3443     $mode ||= 0;
3444     my $protected = 0;
3445
3446     my($fh,@machines,$hasdefault);
3447     $hasdefault = 0;
3448     $fh = FileHandle->new or die "Could not create a filehandle";
3449
3450     if($fh->open($file)){
3451         $protected = ($mode & 077) == 0;
3452         local($/) = "";
3453       NETRC: while (<$fh>) {
3454             my(@tokens) = split " ", $_;
3455           TOKEN: while (@tokens) {
3456                 my($t) = shift @tokens;
3457                 if ($t eq "default"){
3458                     $hasdefault++;
3459                     last NETRC;
3460                 }
3461                 last TOKEN if $t eq "macdef";
3462                 if ($t eq "machine") {
3463                     push @machines, shift @tokens;
3464                 }
3465             }
3466         }
3467     } else {
3468         $file = $hasdefault = $protected = "";
3469     }
3470
3471     bless {
3472            'mach' => [@machines],
3473            'netrc' => $file,
3474            'hasdefault' => $hasdefault,
3475            'protected' => $protected,
3476           }, $class;
3477 }
3478
3479 # CPAN::FTP::netrc::hasdefault;
3480 sub hasdefault { shift->{'hasdefault'} }
3481 sub netrc      { shift->{'netrc'}      }
3482 sub protected  { shift->{'protected'}  }
3483 sub contains {
3484     my($self,$mach) = @_;
3485     for ( @{$self->{'mach'}} ) {
3486         return 1 if $_ eq $mach;
3487     }
3488     return 0;
3489 }
3490
3491 package CPAN::Complete;
3492 use strict;
3493
3494 sub gnu_cpl {
3495     my($text, $line, $start, $end) = @_;
3496     my(@perlret) = cpl($text, $line, $start);
3497     # find longest common match. Can anybody show me how to peruse
3498     # T::R::Gnu to have this done automatically? Seems expensive.
3499     return () unless @perlret;
3500     my($newtext) = $text;
3501     for (my $i = length($text)+1;;$i++) {
3502         last unless length($perlret[0]) && length($perlret[0]) >= $i;
3503         my $try = substr($perlret[0],0,$i);
3504         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
3505         # warn "try[$try]tries[@tries]";
3506         if (@tries == @perlret) {
3507             $newtext = $try;
3508         } else {
3509             last;
3510         }
3511     }
3512     ($newtext,@perlret);
3513 }
3514
3515 #-> sub CPAN::Complete::cpl ;
3516 sub cpl {
3517     my($word,$line,$pos) = @_;
3518     $word ||= "";
3519     $line ||= "";
3520     $pos ||= 0;
3521     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3522     $line =~ s/^\s*//;
3523     if ($line =~ s/^(force\s*)//) {
3524         $pos -= length($1);
3525     }
3526     my @return;
3527     if ($pos == 0) {
3528         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
3529     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
3530         @return = ();
3531     } elsif ($line =~ /^(a|ls)\s/) {
3532         @return = cplx('CPAN::Author',uc($word));
3533     } elsif ($line =~ /^b\s/) {
3534         CPAN::Shell->local_bundles;
3535         @return = cplx('CPAN::Bundle',$word);
3536     } elsif ($line =~ /^d\s/) {
3537         @return = cplx('CPAN::Distribution',$word);
3538     } elsif ($line =~ m/^(
3539                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
3540                          )\s/x ) {
3541         if ($word =~ /^Bundle::/) {
3542             CPAN::Shell->local_bundles;
3543         }
3544         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3545     } elsif ($line =~ /^i\s/) {
3546         @return = cpl_any($word);
3547     } elsif ($line =~ /^reload\s/) {
3548         @return = cpl_reload($word,$line,$pos);
3549     } elsif ($line =~ /^o\s/) {
3550         @return = cpl_option($word,$line,$pos);
3551     } elsif ($line =~ m/^\S+\s/ ) {
3552         # fallback for future commands and what we have forgotten above
3553         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
3554     } else {
3555         @return = ();
3556     }
3557     return @return;
3558 }
3559
3560 #-> sub CPAN::Complete::cplx ;
3561 sub cplx {
3562     my($class, $word) = @_;
3563     # I believed for many years that this was sorted, today I
3564     # realized, it wasn't sorted anymore. Now (rev 1.301 / v 1.55) I
3565     # make it sorted again. Maybe sort was dropped when GNU-readline
3566     # support came in? The RCS file is difficult to read on that:-(
3567     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
3568 }
3569
3570 #-> sub CPAN::Complete::cpl_any ;
3571 sub cpl_any {
3572     my($word) = shift;
3573     return (
3574             cplx('CPAN::Author',$word),
3575             cplx('CPAN::Bundle',$word),
3576             cplx('CPAN::Distribution',$word),
3577             cplx('CPAN::Module',$word),
3578            );
3579 }
3580
3581 #-> sub CPAN::Complete::cpl_reload ;
3582 sub cpl_reload {
3583     my($word,$line,$pos) = @_;
3584     $word ||= "";
3585     my(@words) = split " ", $line;
3586     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3587     my(@ok) = qw(cpan index);
3588     return @ok if @words == 1;
3589     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
3590 }
3591
3592 #-> sub CPAN::Complete::cpl_option ;
3593 sub cpl_option {
3594     my($word,$line,$pos) = @_;
3595     $word ||= "";
3596     my(@words) = split " ", $line;
3597     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
3598     my(@ok) = qw(conf debug);
3599     return @ok if @words == 1;
3600     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
3601     if (0) {
3602     } elsif ($words[1] eq 'index') {
3603         return ();
3604     } elsif ($words[1] eq 'conf') {
3605         return CPAN::HandleConfig::cpl(@_);
3606     } elsif ($words[1] eq 'debug') {
3607         return sort grep /^\Q$word\E/i,
3608             sort keys %CPAN::DEBUG, 'all';
3609     }
3610 }
3611
3612 package CPAN::Index;
3613 use strict;
3614
3615 #-> sub CPAN::Index::force_reload ;
3616 sub force_reload {
3617     my($class) = @_;
3618     $CPAN::Index::LAST_TIME = 0;
3619     $class->reload(1);
3620 }
3621
3622 #-> sub CPAN::Index::reload ;
3623 sub reload {
3624     my($cl,$force) = @_;
3625     my $time = time;
3626
3627     # XXX check if a newer one is available. (We currently read it
3628     # from time to time)
3629     for ($CPAN::Config->{index_expire}) {
3630         $_ = 0.001 unless $_ && $_ > 0.001;
3631     }
3632     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
3633         # debug here when CPAN doesn't seem to read the Metadata
3634         require Carp;
3635         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
3636     }
3637     unless ($CPAN::META->{PROTOCOL}) {
3638         $cl->read_metadata_cache;
3639         $CPAN::META->{PROTOCOL} ||= "1.0";
3640     }
3641     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
3642         # warn "Setting last_time to 0";
3643         $LAST_TIME = 0; # No warning necessary
3644     }
3645     return if $LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
3646         and ! $force;
3647     if (0) {
3648         # IFF we are developing, it helps to wipe out the memory
3649         # between reloads, otherwise it is not what a user expects.
3650         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
3651         $CPAN::META = CPAN->new;
3652     }
3653     {
3654         my($debug,$t2);
3655         local $LAST_TIME = $time;
3656         local $CPAN::META->{PROTOCOL} = PROTOCOL;
3657
3658         my $needshort = $^O eq "dos";
3659
3660         $cl->rd_authindex($cl
3661                           ->reload_x(
3662                                      "authors/01mailrc.txt.gz",
3663                                      $needshort ?
3664                                      File::Spec->catfile('authors', '01mailrc.gz') :
3665                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
3666                                      $force));
3667         $t2 = time;
3668         $debug = "timing reading 01[".($t2 - $time)."]";
3669         $time = $t2;
3670         return if $CPAN::Signal; # this is sometimes lengthy
3671         $cl->rd_modpacks($cl
3672                          ->reload_x(
3673                                     "modules/02packages.details.txt.gz",
3674                                     $needshort ?
3675                                     File::Spec->catfile('modules', '02packag.gz') :
3676                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
3677                                     $force));
3678         $t2 = time;
3679         $debug .= "02[".($t2 - $time)."]";
3680         $time = $t2;
3681         return if $CPAN::Signal; # this is sometimes lengthy
3682         $cl->rd_modlist($cl
3683                         ->reload_x(
3684                                    "modules/03modlist.data.gz",
3685                                    $needshort ?
3686                                    File::Spec->catfile('modules', '03mlist.gz') :
3687                                    File::Spec->catfile('modules', '03modlist.data.gz'),
3688                                    $force));
3689         $cl->write_metadata_cache;
3690         $t2 = time;
3691         $debug .= "03[".($t2 - $time)."]";
3692         $time = $t2;
3693         CPAN->debug($debug) if $CPAN::DEBUG;
3694     }
3695     $LAST_TIME = $time;
3696     $CPAN::META->{PROTOCOL} = PROTOCOL;
3697 }
3698
3699 #-> sub CPAN::Index::reload_x ;
3700 sub reload_x {
3701     my($cl,$wanted,$localname,$force) = @_;
3702     $force |= 2; # means we're dealing with an index here
3703     CPAN::HandleConfig->load; # we should guarantee loading wherever
3704                               # we rely on Config XXX
3705     $localname ||= $wanted;
3706     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
3707                                          $localname);
3708     if (
3709         -f $abs_wanted &&
3710         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
3711         !($force & 1)
3712        ) {
3713         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
3714         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
3715                    qq{day$s. I\'ll use that.});
3716         return $abs_wanted;
3717     } else {
3718         $force |= 1; # means we're quite serious about it.
3719     }
3720     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
3721 }
3722
3723 #-> sub CPAN::Index::rd_authindex ;
3724 sub rd_authindex {
3725     my($cl, $index_target) = @_;
3726     my @lines;
3727     return unless defined $index_target;
3728     $CPAN::Frontend->myprint("Going to read $index_target\n");
3729     local(*FH);
3730     tie *FH, 'CPAN::Tarzip', $index_target;
3731     local($/) = "\n";
3732     local($_);
3733     push @lines, split /\012/ while <FH>;
3734     my $i = 0;
3735     my $modulus = int($#lines/75) || 1;
3736     CPAN->debug(sprintf "modulus[%d]lines[%s]", $modulus, scalar @lines) if $CPAN::DEBUG;
3737     foreach (@lines) {
3738         my($userid,$fullname,$email) =
3739             m/alias\s+(\S+)\s+\"([^\"\<]+)\s+\<([^\>]+)\>\"/;
3740         next unless $userid && $fullname && $email;
3741
3742         # instantiate an author object
3743         my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
3744         $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
3745         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3746         return if $CPAN::Signal;
3747     }
3748     $CPAN::Frontend->myprint("DONE\n");
3749 }
3750
3751 sub userid {
3752   my($self,$dist) = @_;
3753   $dist = $self->{'id'} unless defined $dist;
3754   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
3755   $ret;
3756 }
3757
3758 #-> sub CPAN::Index::rd_modpacks ;
3759 sub rd_modpacks {
3760     my($self, $index_target) = @_;
3761     return unless defined $index_target;
3762     $CPAN::Frontend->myprint("Going to read $index_target\n");
3763     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3764     local $_;
3765     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
3766     my $slurp = "";
3767     my $chunk;
3768     while (my $bytes = $fh->READ(\$chunk,8192)) {
3769         $slurp.=$chunk;
3770     }
3771     my @lines = split /\012/, $slurp;
3772     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
3773     undef $fh;
3774     # read header
3775     my($line_count,$last_updated);
3776     while (@lines) {
3777         my $shift = shift(@lines);
3778         last if $shift =~ /^\s*$/;
3779         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
3780         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
3781     }
3782     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
3783     if (not defined $line_count) {
3784
3785         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
3786 Please check the validity of the index file by comparing it to more
3787 than one CPAN mirror. I'll continue but problems seem likely to
3788 happen.\a
3789 });
3790
3791         $CPAN::Frontend->mysleep(5);
3792     } elsif ($line_count != scalar @lines) {
3793
3794         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
3795 contains a Line-Count header of %d but I see %d lines there. Please
3796 check the validity of the index file by comparing it to more than one
3797 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
3798 $index_target, $line_count, scalar(@lines));
3799
3800     }
3801     if (not defined $last_updated) {
3802
3803         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
3804 Please check the validity of the index file by comparing it to more
3805 than one CPAN mirror. I'll continue but problems seem likely to
3806 happen.\a
3807 });
3808
3809         $CPAN::Frontend->mysleep(5);
3810     } else {
3811
3812         $CPAN::Frontend
3813             ->myprint(sprintf qq{  Database was generated on %s\n},
3814                       $last_updated);
3815         $DATE_OF_02 = $last_updated;
3816
3817         my $age = time;
3818         if ($CPAN::META->has_inst('HTTP::Date')) {
3819             require HTTP::Date;
3820             $age -= HTTP::Date::str2time($last_updated);
3821         } else {
3822             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
3823             require Time::Local;
3824             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
3825             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
3826             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
3827         }
3828         $age /= 3600*24;
3829         if ($age > 30) {
3830
3831             $CPAN::Frontend
3832                 ->mywarn(sprintf
3833                          qq{Warning: This index file is %d days old.
3834   Please check the host you chose as your CPAN mirror for staleness.
3835   I'll continue but problems seem likely to happen.\a\n},
3836                          $age);
3837
3838         } elsif ($age < -1) {
3839
3840             $CPAN::Frontend
3841                 ->mywarn(sprintf
3842                          qq{Warning: Your system date is %d days behind this index file!
3843   System time:          %s
3844   Timestamp index file: %s
3845   Please fix your system time, problems with the make command expected.\n},
3846                          -$age,
3847                          scalar gmtime,
3848                          $DATE_OF_02,
3849                         );
3850
3851         }
3852     }
3853
3854
3855     # A necessity since we have metadata_cache: delete what isn't
3856     # there anymore
3857     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
3858     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
3859     my(%exists);
3860     my $i = 0;
3861     my $modulus = int($#lines/75) || 1;
3862     foreach (@lines) {
3863         # before 1.56 we split into 3 and discarded the rest. From
3864         # 1.57 we assign remaining text to $comment thus allowing to
3865         # influence isa_perl
3866         my($mod,$version,$dist,$comment) = split " ", $_, 4;
3867         my($bundle,$id,$userid);
3868
3869         if ($mod eq 'CPAN' &&
3870             ! (
3871                CPAN::Queue->exists('Bundle::CPAN') ||
3872                CPAN::Queue->exists('CPAN')
3873               )
3874            ) {
3875             local($^W)= 0;
3876             if ($version > $CPAN::VERSION){
3877                 $CPAN::Frontend->mywarn(qq{
3878   New CPAN.pm version (v$version) available.
3879   [Currently running version is v$CPAN::VERSION]
3880   You might want to try
3881     install CPAN
3882     reload cpan
3883   to both upgrade CPAN.pm and run the new version without leaving
3884   the current session.
3885
3886 }); #});
3887                 $CPAN::Frontend->mysleep(2);
3888                 $CPAN::Frontend->myprint(qq{\n});
3889             }
3890             last if $CPAN::Signal;
3891         } elsif ($mod =~ /^Bundle::(.*)/) {
3892             $bundle = $1;
3893         }
3894
3895         if ($bundle){
3896             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
3897             # Let's make it a module too, because bundles have so much
3898             # in common with modules.
3899
3900             # Changed in 1.57_63: seems like memory bloat now without
3901             # any value, so commented out
3902
3903             # $CPAN::META->instance('CPAN::Module',$mod);
3904
3905         } else {
3906
3907             # instantiate a module object
3908             $id = $CPAN::META->instance('CPAN::Module',$mod);
3909
3910         }
3911
3912         # Although CPAN prohibits same name with different version the
3913         # indexer may have changed the version for the same distro
3914         # since the last time ("Force Reindexing" feature)
3915         if ($id->cpan_file ne $dist
3916             ||
3917             $id->cpan_version ne $version
3918            ){
3919             $userid = $id->userid || $self->userid($dist);
3920             $id->set(
3921                      'CPAN_USERID' => $userid,
3922                      'CPAN_VERSION' => $version,
3923                      'CPAN_FILE' => $dist,
3924                     );
3925         }
3926
3927         # instantiate a distribution object
3928         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
3929           # we do not need CONTAINSMODS unless we do something with
3930           # this dist, so we better produce it on demand.
3931
3932           ## my $obj = $CPAN::META->instance(
3933           ##                              'CPAN::Distribution' => $dist
3934           ##                             );
3935           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
3936         } else {
3937           $CPAN::META->instance(
3938                                 'CPAN::Distribution' => $dist
3939                                )->set(
3940                                       'CPAN_USERID' => $userid,
3941                                       'CPAN_COMMENT' => $comment,
3942                                      );
3943         }
3944         if ($secondtime) {
3945             for my $name ($mod,$dist) {
3946                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
3947                 $exists{$name} = undef;
3948             }
3949         }
3950         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
3951         return if $CPAN::Signal;
3952     }
3953     $CPAN::Frontend->myprint("DONE\n");
3954     if ($secondtime) {
3955         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
3956             for my $o ($CPAN::META->all_objects($class)) {
3957                 next if exists $exists{$o->{ID}};
3958                 $CPAN::META->delete($class,$o->{ID});
3959                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
3960                 #     if $CPAN::DEBUG;
3961             }
3962         }
3963     }
3964 }
3965
3966 #-> sub CPAN::Index::rd_modlist ;
3967 sub rd_modlist {
3968     my($cl,$index_target) = @_;
3969     return unless defined $index_target;
3970     $CPAN::Frontend->myprint("Going to read $index_target\n");
3971     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
3972     local $_;
3973     my $slurp = "";
3974     my $chunk;
3975     while (my $bytes = $fh->READ(\$chunk,8192)) {
3976         $slurp.=$chunk;
3977     }
3978     my @eval2 = split /\012/, $slurp;
3979
3980     while (@eval2) {
3981         my $shift = shift(@eval2);
3982         if ($shift =~ /^Date:\s+(.*)/){
3983             if ($DATE_OF_03 eq $1){
3984                 $CPAN::Frontend->myprint("Unchanged.\n");
3985                 return;
3986             }
3987             ($DATE_OF_03) = $1;
3988         }
3989         last if $shift =~ /^\s*$/;
3990     }
3991     push @eval2, q{CPAN::Modulelist->data;};
3992     local($^W) = 0;
3993     my($comp) = Safe->new("CPAN::Safe1");
3994     my($eval2) = join("\n", @eval2);
3995     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
3996     my $ret = $comp->reval($eval2);
3997     Carp::confess($@) if $@;
3998     return if $CPAN::Signal;
3999     my $i = 0;
4000     my $until = keys(%$ret) - 1;
4001     my $modulus = int($until/75) || 1;
4002     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4003     for (keys %$ret) {
4004         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4005         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4006         $obj->set(%{$ret->{$_}});
4007         $CPAN::Frontend->myprint(".") unless $i++ % $modulus;
4008         return if $CPAN::Signal;
4009     }
4010     $CPAN::Frontend->myprint("DONE\n");
4011 }
4012
4013 #-> sub CPAN::Index::write_metadata_cache ;
4014 sub write_metadata_cache {
4015     my($self) = @_;
4016     return unless $CPAN::Config->{'cache_metadata'};
4017     return unless $CPAN::META->has_usable("Storable");
4018     my $cache;
4019     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4020                       CPAN::Distribution)) {
4021         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4022     }
4023     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4024     $cache->{last_time} = $LAST_TIME;
4025     $cache->{DATE_OF_02} = $DATE_OF_02;
4026     $cache->{PROTOCOL} = PROTOCOL;
4027     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4028     eval { Storable::nstore($cache, $metadata_file) };
4029     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4030 }
4031
4032 #-> sub CPAN::Index::read_metadata_cache ;
4033 sub read_metadata_cache {
4034     my($self) = @_;
4035     return unless $CPAN::Config->{'cache_metadata'};
4036     return unless $CPAN::META->has_usable("Storable");
4037     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4038     return unless -r $metadata_file and -f $metadata_file;
4039     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4040     my $cache;
4041     eval { $cache = Storable::retrieve($metadata_file) };
4042     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4043     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4044         $LAST_TIME = 0;
4045         return;
4046     }
4047     if (exists $cache->{PROTOCOL}) {
4048         if (PROTOCOL > $cache->{PROTOCOL}) {
4049             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4050                                             "with protocol v%s, requiring v%s\n",
4051                                             $cache->{PROTOCOL},
4052                                             PROTOCOL)
4053                                    );
4054             return;
4055         }
4056     } else {
4057         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4058                                 "with protocol v1.0\n");
4059         return;
4060     }
4061     my $clcnt = 0;
4062     my $idcnt = 0;
4063     while(my($class,$v) = each %$cache) {
4064         next unless $class =~ /^CPAN::/;
4065         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4066         while (my($id,$ro) = each %$v) {
4067             $CPAN::META->{readwrite}{$class}{$id} ||=
4068                 $class->new(ID=>$id, RO=>$ro);
4069             $idcnt++;
4070         }
4071         $clcnt++;
4072     }
4073     unless ($clcnt) { # sanity check
4074         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4075         return;
4076     }
4077     if ($idcnt < 1000) {
4078         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4079                                  "in $metadata_file\n");
4080         return;
4081     }
4082     $CPAN::META->{PROTOCOL} ||=
4083         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4084                             # does initialize to some protocol
4085     $LAST_TIME = $cache->{last_time};
4086     $DATE_OF_02 = $cache->{DATE_OF_02};
4087     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4088         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4089     return;
4090 }
4091
4092 package CPAN::InfoObj;
4093 use strict;
4094
4095 sub ro {
4096     my $self = shift;
4097     exists $self->{RO} and return $self->{RO};
4098 }
4099
4100 sub cpan_userid {
4101     my $self = shift;
4102     my $ro = $self->ro or return "N/A"; # N/A for bundles found locally
4103     return $ro->{CPAN_USERID} || "N/A";
4104 }
4105
4106 sub id { shift->{ID}; }
4107
4108 #-> sub CPAN::InfoObj::new ;
4109 sub new {
4110     my $this = bless {}, shift;
4111     %$this = @_;
4112     $this
4113 }
4114
4115 # The set method may only be used by code that reads index data or
4116 # otherwise "objective" data from the outside world. All session
4117 # related material may do anything else with instance variables but
4118 # must not touch the hash under the RO attribute. The reason is that
4119 # the RO hash gets written to Metadata file and is thus persistent.
4120
4121 #-> sub CPAN::InfoObj::safe_chdir ;
4122 sub safe_chdir {
4123   my($self,$todir) = @_;
4124   # we die if we cannot chdir and we are debuggable
4125   Carp::confess("safe_chdir called without todir argument")
4126         unless defined $todir and length $todir;
4127   if (chdir $todir) {
4128     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4129         if $CPAN::DEBUG;
4130   } else {
4131     if (-e $todir) {
4132         unless (-x $todir) {
4133             unless (chmod 0755, $todir) {
4134                 my $cwd = CPAN::anycwd();
4135                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
4136                                         "permission to change the permission; cannot ".
4137                                         "chdir to '$todir'\n");
4138                 $CPAN::Frontend->mysleep(5);
4139                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4140                                        qq{to todir[$todir]: $!});
4141             }
4142         }
4143     } else {
4144         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
4145     }
4146     if (chdir $todir) {
4147       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
4148           if $CPAN::DEBUG;
4149     } else {
4150       my $cwd = CPAN::anycwd();
4151       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
4152                              qq{to todir[$todir] (a chmod has been issued): $!});
4153     }
4154   }
4155 }
4156
4157 #-> sub CPAN::InfoObj::set ;
4158 sub set {
4159     my($self,%att) = @_;
4160     my $class = ref $self;
4161
4162     # This must be ||=, not ||, because only if we write an empty
4163     # reference, only then the set method will write into the readonly
4164     # area. But for Distributions that spring into existence, maybe
4165     # because of a typo, we do not like it that they are written into
4166     # the readonly area and made permanent (at least for a while) and
4167     # that is why we do not "allow" other places to call ->set.
4168     unless ($self->id) {
4169         CPAN->debug("Bug? Empty ID, rejecting");
4170         return;
4171     }
4172     my $ro = $self->{RO} =
4173         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
4174
4175     while (my($k,$v) = each %att) {
4176         $ro->{$k} = $v;
4177     }
4178 }
4179
4180 #-> sub CPAN::InfoObj::as_glimpse ;
4181 sub as_glimpse {
4182     my($self) = @_;
4183     my(@m);
4184     my $class = ref($self);
4185     $class =~ s/^CPAN:://;
4186     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
4187     push @m, sprintf "%-15s %s\n", $class, $id;
4188     join "", @m;
4189 }
4190
4191 #-> sub CPAN::InfoObj::as_string ;
4192 sub as_string {
4193     my($self) = @_;
4194     my(@m);
4195     my $class = ref($self);
4196     $class =~ s/^CPAN:://;
4197     push @m, $class, " id = $self->{ID}\n";
4198     my $ro;
4199     unless ($ro = $self->ro) {
4200         $CPAN::Frontend->mydie("Unknown object $self->{ID}");
4201     }
4202     for (sort keys %$ro) {
4203         # next if m/^(ID|RO)$/;
4204         my $extra = "";
4205         if ($_ eq "CPAN_USERID") {
4206             $extra .= " (";
4207             $extra .= $self->fullname;
4208             my $email; # old perls!
4209             if ($email = $CPAN::META->instance("CPAN::Author",
4210                                                $self->cpan_userid
4211                                               )->email) {
4212                 $extra .= " <$email>";
4213             } else {
4214                 $extra .= " <no email>";
4215             }
4216             $extra .= ")";
4217         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
4218             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
4219             next;
4220         }
4221         next unless defined $ro->{$_};
4222         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
4223     }
4224     for (sort keys %$self) {
4225         next if m/^(ID|RO)$/;
4226         if (ref($self->{$_}) eq "ARRAY") {
4227           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
4228         } elsif (ref($self->{$_}) eq "HASH") {
4229           push @m, sprintf(
4230                            "    %-12s %s\n",
4231                            $_,
4232                            join(" ",sort keys %{$self->{$_}}),
4233                           );
4234         } else {
4235           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
4236         }
4237     }
4238     join "", @m, "\n";
4239 }
4240
4241 #-> sub CPAN::InfoObj::fullname ;
4242 sub fullname {
4243     my($self) = @_;
4244     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
4245 }
4246
4247 #-> sub CPAN::InfoObj::dump ;
4248 sub dump {
4249   my($self, $what) = @_;
4250   unless ($CPAN::META->has_inst("Data::Dumper")) {
4251       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
4252   }
4253   local $Data::Dumper::Sortkeys;
4254   $Data::Dumper::Sortkeys = 1;
4255   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
4256   if (length $out > 100000) {
4257       my $fh_pager = FileHandle->new;
4258       local($SIG{PIPE}) = "IGNORE";
4259       my $pager = $CPAN::Config->{'pager'} || "cat";
4260       $fh_pager->open("|$pager")
4261           or die "Could not open pager $pager\: $!";
4262       $fh_pager->print($out);
4263       close $fh_pager;
4264   } else {
4265       $CPAN::Frontend->myprint($out);
4266   }
4267 }
4268
4269 package CPAN::Author;
4270 use strict;
4271
4272 #-> sub CPAN::Author::force
4273 sub force {
4274     my $self = shift;
4275     $self->{force}++;
4276 }
4277
4278 #-> sub CPAN::Author::force
4279 sub unforce {
4280     my $self = shift;
4281     delete $self->{force};
4282 }
4283
4284 #-> sub CPAN::Author::id
4285 sub id {
4286     my $self = shift;
4287     my $id = $self->{ID};
4288     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
4289     $id;
4290 }
4291
4292 #-> sub CPAN::Author::as_glimpse ;
4293 sub as_glimpse {
4294     my($self) = @_;
4295     my(@m);
4296     my $class = ref($self);
4297     $class =~ s/^CPAN:://;
4298     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
4299                      $class,
4300                      $self->{ID},
4301                      $self->fullname,
4302                      $self->email);
4303     join "", @m;
4304 }
4305
4306 #-> sub CPAN::Author::fullname ;
4307 sub fullname {
4308     shift->ro->{FULLNAME};
4309 }
4310 *name = \&fullname;
4311
4312 #-> sub CPAN::Author::email ;
4313 sub email    { shift->ro->{EMAIL}; }
4314
4315 #-> sub CPAN::Author::ls ;
4316 sub ls {
4317     my $self = shift;
4318     my $glob = shift || "";
4319     my $silent = shift || 0;
4320     my $id = $self->id;
4321
4322     # adapted from CPAN::Distribution::verifyCHECKSUM ;
4323     my(@csf); # chksumfile
4324     @csf = $self->id =~ /(.)(.)(.*)/;
4325     $csf[1] = join "", @csf[0,1];
4326     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
4327     my(@dl);
4328     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
4329     unless (grep {$_->[2] eq $csf[1]} @dl) {
4330         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
4331         return;
4332     }
4333     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
4334     unless (grep {$_->[2] eq $csf[2]} @dl) {
4335         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
4336         return;
4337     }
4338     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
4339     if ($glob) {
4340         if ($CPAN::META->has_inst("Text::Glob")) {
4341             my $rglob = Text::Glob::glob_to_regex($glob);
4342             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
4343         } else {
4344             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
4345         }
4346     }
4347     $CPAN::Frontend->myprint(join "", map {
4348         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
4349     } sort { $a->[2] cmp $b->[2] } @dl);
4350     @dl;
4351 }
4352
4353 # returns an array of arrays, the latter contain (size,mtime,filename)
4354 #-> sub CPAN::Author::dir_listing ;
4355 sub dir_listing {
4356     my $self = shift;
4357     my $chksumfile = shift;
4358     my $recursive = shift;
4359     my $may_ftp = shift;
4360
4361     my $lc_want =
4362         File::Spec->catfile($CPAN::Config->{keep_source_where},
4363                             "authors", "id", @$chksumfile);
4364
4365     my $fh;
4366
4367     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
4368     # hazard.  (Without GPG installed they are not that much better,
4369     # though.)
4370     $fh = FileHandle->new;
4371     if (open($fh, $lc_want)) {
4372         my $line = <$fh>; close $fh;
4373         unlink($lc_want) unless $line =~ /PGP/;
4374     }
4375
4376     local($") = "/";
4377     # connect "force" argument with "index_expire".
4378     my $force = $self->{force};
4379     if (my @stat = stat $lc_want) {
4380         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
4381     }
4382     my $lc_file;
4383     if ($may_ftp) {
4384         $lc_file = CPAN::FTP->localize(
4385                                        "authors/id/@$chksumfile",
4386                                        $lc_want,
4387                                        $force,
4388                                       );
4389         unless ($lc_file) {
4390             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
4391             $chksumfile->[-1] .= ".gz";
4392             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
4393                                            "$lc_want.gz",1);
4394             if ($lc_file) {
4395                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
4396                 CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file);
4397             } else {
4398                 return;
4399             }
4400         }
4401     } else {
4402         $lc_file = $lc_want;
4403         # we *could* second-guess and if the user has a file: URL,
4404         # then we could look there. But on the other hand, if they do
4405         # have a file: URL, wy did they choose to set
4406         # $CPAN::Config->{show_upload_date} to false?
4407     }
4408
4409     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
4410     $fh = FileHandle->new;
4411     my($cksum);
4412     if (open $fh, $lc_file){
4413         local($/);
4414         my $eval = <$fh>;
4415         $eval =~ s/\015?\012/\n/g;
4416         close $fh;
4417         my($comp) = Safe->new();
4418         $cksum = $comp->reval($eval);
4419         if ($@) {
4420             rename $lc_file, "$lc_file.bad";
4421             Carp::confess($@) if $@;
4422         }
4423     } elsif ($may_ftp) {
4424         Carp::carp "Could not open '$lc_file' for reading.";
4425     } else {
4426         # Maybe should warn: "You may want to set show_upload_date to a true value"
4427         return;
4428     }
4429     my(@result,$f);
4430     for $f (sort keys %$cksum) {
4431         if (exists $cksum->{$f}{isdir}) {
4432             if ($recursive) {
4433                 my(@dir) = @$chksumfile;
4434                 pop @dir;
4435                 push @dir, $f, "CHECKSUMS";
4436                 push @result, map {
4437                     [$_->[0], $_->[1], "$f/$_->[2]"]
4438                 } $self->dir_listing(\@dir,1,$may_ftp);
4439             } else {
4440                 push @result, [ 0, "-", $f ];
4441             }
4442         } else {
4443             push @result, [
4444                            ($cksum->{$f}{"size"}||0),
4445                            $cksum->{$f}{"mtime"}||"---",
4446                            $f
4447                           ];
4448         }
4449     }
4450     @result;
4451 }
4452
4453 package CPAN::Distribution;
4454 use strict;
4455
4456 # Accessors
4457 sub cpan_comment {
4458     my $self = shift;
4459     my $ro = $self->ro or return;
4460     $ro->{CPAN_COMMENT}
4461 }