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