lib/CPAN.pm

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