lib/CPAN.pm

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