lib/CPAN.pm

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