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