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