lib/CPAN.pm

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