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