lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.88_78';
   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) unless ref $inc;
  38         }
  39     }
  40 }
  41 no lib ".";
  42
  43 require Mac::BuildTools if $^O eq 'MacOS';
  44 $ENV{PERL5_CPAN_IS_RUNNING}=1;
  45 $ENV{PERL5_CPANPLUS_IS_RUNNING}=1; # https://rt.cpan.org/Ticket/Display.html?id=23735
  46
  47 END { $CPAN::End++; &cleanup; }
  48
  49 $CPAN::Signal ||= 0;
  50 $CPAN::Frontend ||= "CPAN::Shell";
  51 unless (@CPAN::Defaultsites){
  52     @CPAN::Defaultsites = map {
  53         CPAN::URL->new(TEXT => $_, FROM => "DEF")
  54     }
  55         "http://www.perl.org/CPAN/",
  56             "ftp://ftp.perl.org/pub/CPAN/";
  57 }
  58 # $CPAN::iCwd (i for initial) is going to be initialized during find_perl
  59 $CPAN::Perl ||= CPAN::find_perl();
  60 $CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
  61 $CPAN::Defaultrecent ||= "http://search.cpan.org/recent";
  62
  63 # our globals are getting a mess
  64 use vars qw(
  65             $AUTOLOAD
  66             $Be_Silent
  67             $CONFIG_DIRTY
  68             $Defaultdocs
  69             $Defaultrecent
  70             $Echo_readline
  71             $Frontend
  72             $GOTOSHELL
  73             $HAS_USABLE
  74             $Have_warned
  75             $MAX_RECURSION
  76             $META
  77             $RUN_DEGRADED
  78             $Signal
  79             $SQLite
  80             $Suppress_readline
  81             $VERSION
  82             $autoload_recursion
  83             $term
  84             @Defaultsites
  85             @EXPORT
  86            );
  87
  88 $MAX_RECURSION = 32;
  89
  90 @CPAN::ISA = qw(CPAN::Debug Exporter);
  91
  92 # note that these functions live in CPAN::Shell and get executed via
  93 # AUTOLOAD when called directly
  94 @EXPORT = qw(
  95              autobundle
  96              bundle
  97              clean
  98              cvs_import
  99              expand
 100              force
 101              fforce
 102              get
 103              install
 104              install_tested
 105              is_tested
 106              make
 107              mkmyconfig
 108              notest
 109              perldoc
 110              readme
 111              recent
 112              recompile
 113              report
 114              shell
 115              test
 116              upgrade
 117             );
 118
 119 sub soft_chdir_with_alternatives ($);
 120
 121 {
 122     $autoload_recursion ||= 0;
 123
 124     #-> sub CPAN::AUTOLOAD ;
 125     sub AUTOLOAD {
 126         $autoload_recursion++;
 127         my($l) = $AUTOLOAD;
 128         $l =~ s/.*:://;
 129         if ($CPAN::Signal) {
 130             warn "Refusing to autoload '$l' while signal pending";
 131             $autoload_recursion--;
 132             return;
 133         }
 134         if ($autoload_recursion > 1) {
 135             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 136             warn "Refusing to autoload $fullcommand in recursion\n";
 137             $autoload_recursion--;
 138             return;
 139         }
 140         my(%export);
 141         @export{@EXPORT} = '';
 142         CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 143         if (exists $export{$l}){
 144             CPAN::Shell->$l(@_);
 145         } else {
 146             die(qq{Unknown CPAN command "$AUTOLOAD". }.
 147                 qq{Type ? for help.\n});
 148         }
 149         $autoload_recursion--;
 150     }
 151 }
 152
 153 #-> sub CPAN::shell ;
 154 sub shell {
 155     my($self) = @_;
 156     $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
 157     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 158
 159     my $oprompt = shift || CPAN::Prompt->new;
 160     my $prompt = $oprompt;
 161     my $commandline = shift || "";
 162     $CPAN::CurrentCommandId ||= 1;
 163
 164     local($^W) = 1;
 165     unless ($Suppress_readline) {
 166         require Term::ReadLine;
 167         if (! $term
 168             or
 169             $term->ReadLine eq "Term::ReadLine::Stub"
 170            ) {
 171             $term = Term::ReadLine->new('CPAN Monitor');
 172         }
 173         if ($term->ReadLine eq "Term::ReadLine::Gnu") {
 174             my $attribs = $term->Attribs;
 175              $attribs->{attempted_completion_function} = sub {
 176                  &CPAN::Complete::gnu_cpl;
 177              }
 178         } else {
 179             $readline::rl_completion_function =
 180                 $readline::rl_completion_function = 'CPAN::Complete::cpl';
 181         }
 182         if (my $histfile = $CPAN::Config->{'histfile'}) {{
 183             unless ($term->can("AddHistory")) {
 184                 $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
 185                 last;
 186             }
 187             $META->readhist($term,$histfile);
 188         }}
 189         for ($CPAN::Config->{term_ornaments}) { # alias
 190             local $Term::ReadLine::termcap_nowarn = 1;
 191             $term->ornaments($_) if defined;
 192         }
 193         # $term->OUT is autoflushed anyway
 194         my $odef = select STDERR;
 195         $| = 1;
 196         select STDOUT;
 197         $| = 1;
 198         select $odef;
 199     }
 200
 201     $META->checklock();
 202     my @cwd = grep { defined $_ and length $_ }
 203         CPAN::anycwd(),
 204               File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
 205                     File::Spec->rootdir();
 206     my $try_detect_readline;
 207     $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
 208     my $rl_avail = $Suppress_readline ? "suppressed" :
 209         ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
 210             "available (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             if ($Echo_readline) {
 228                 $|=1;
 229             }
 230             print $prompt;
 231             last SHELLCOMMAND unless defined ($_ = <> );
 232             if ($Echo_readline) {
 233                 # backdoor: I could not find a way to record sessions
 234                 print $_;
 235             }
 236             chomp;
 237         } else {
 238             last SHELLCOMMAND unless
 239                 defined ($_ = $term->readline($prompt, $commandline));
 240         }
 241         $_ = "$continuation$_" if $continuation;
 242         s/^\s+//;
 243         next SHELLCOMMAND if /^$/;
 244         $_ = 'h' if /^\s*\?/;
 245         if (/^(?:q(?:uit)?|bye|exit)$/i) {
 246             last SHELLCOMMAND;
 247         } elsif (s/\\$//s) {
 248             chomp;
 249             $continuation = $_;
 250             $prompt = "    > ";
 251         } elsif (/^\!/) {
 252             s/^\!//;
 253             my($eval) = $_;
 254             package CPAN::Eval;
 255             use strict;
 256             use vars qw($import_done);
 257             CPAN->import(':DEFAULT') unless $import_done++;
 258             CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
 259             eval($eval);
 260             warn $@ if $@;
 261             $continuation = "";
 262             $prompt = $oprompt;
 263         } elsif (/./) {
 264             my(@line);
 265             eval { @line = Text::ParseWords::shellwords($_) };
 266             warn($@), next SHELLCOMMAND if $@;
 267             warn("Text::Parsewords could not parse the line [$_]"),
 268                 next SHELLCOMMAND unless @line;
 269             $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG;
 270             my $command = shift @line;
 271             eval { CPAN::Shell->$command(@line) };
 272             if ($@ && "$@" =~ /\S/){
 273                 require Carp;
 274                 Carp::cluck("Catching error: '$@'");
 275             }
 276             if ($command =~ /^(make|test|install|ff?orce|notest|clean|report|upgrade)$/) {
 277                 CPAN::Shell->failed($CPAN::CurrentCommandId,1);
 278             }
 279             soft_chdir_with_alternatives(\@cwd);
 280             $CPAN::Frontend->myprint("\n");
 281             $continuation = "";
 282             $CPAN::CurrentCommandId++;
 283             $prompt = $oprompt;
 284         }
 285     } continue {
 286       $commandline = ""; # I do want to be able to pass a default to
 287                          # shell, but on the second command I see no
 288                          # use in that
 289       $Signal=0;
 290       CPAN::Queue->nullify_queue;
 291       if ($try_detect_readline) {
 292         if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
 293             ||
 294             $CPAN::META->has_inst("Term::ReadLine::Perl")
 295            ) {
 296             delete $INC{"Term/ReadLine.pm"};
 297             my $redef = 0;
 298             local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
 299             require Term::ReadLine;
 300             $CPAN::Frontend->myprint("\n$redef subroutines in ".
 301                                      "Term::ReadLine redefined\n");
 302             $GOTOSHELL = 1;
 303         }
 304       }
 305       if ($term and $term->can("ornaments")) {
 306           for ($CPAN::Config->{term_ornaments}) { # alias
 307               if (defined $_) {
 308                   if (not defined $last_term_ornaments
 309                       or $_ != $last_term_ornaments
 310                      ) {
 311                       local $Term::ReadLine::termcap_nowarn = 1;
 312                       $term->ornaments($_);
 313                       $last_term_ornaments = $_;
 314                   }
 315               } else {
 316                   undef $last_term_ornaments;
 317               }
 318           }
 319       }
 320       for my $class (qw(Module Distribution)) {
 321           # again unsafe meta access?
 322           for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
 323               next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 324               CPAN->debug("BUG: $class '$dm' was in command state, resetting");
 325               delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
 326           }
 327       }
 328       if ($GOTOSHELL) {
 329           $GOTOSHELL = 0; # not too often
 330           $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
 331           @_ = ($oprompt,"");
 332           goto &shell;
 333       }
 334     }
 335     soft_chdir_with_alternatives(\@cwd);
 336 }
 337
 338 sub soft_chdir_with_alternatives ($) {
 339     my($cwd) = @_;
 340     unless (@$cwd) {
 341         my $root = File::Spec->rootdir();
 342         $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
 343 Trying '$root' as temporary haven.
 344 });
 345         push @$cwd, $root;
 346     }
 347     while () {
 348         if (chdir $cwd->[0]) {
 349             return;
 350         } else {
 351             if (@$cwd>1) {
 352                 $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
 353 Trying to chdir to "$cwd->[1]" instead.
 354 });
 355                 shift @$cwd;
 356             } else {
 357                 $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
 358             }
 359         }
 360     }
 361 }
 362
 363 sub _yaml_module () {
 364     my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
 365     if (
 366         $yaml_module ne "YAML"
 367         &&
 368         !$CPAN::META->has_inst($yaml_module)
 369        ) {
 370         # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
 371         $yaml_module = "YAML";
 372     }
 373     return $yaml_module;
 374 }
 375
 376 # CPAN::_yaml_loadfile
 377 sub _yaml_loadfile {
 378     my($self,$local_file) = @_;
 379     return +[] unless -s $local_file;
 380     my $yaml_module = _yaml_module;
 381     if ($CPAN::META->has_inst($yaml_module)) {
 382         my $code;
 383         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 384             my @yaml;
 385             eval { @yaml = $code->($local_file); };
 386             if ($@) {
 387                 # this shall not be done by the frontend
 388                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 389             }
 390             return \@yaml;
 391         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 392             local *FH;
 393             open FH, $local_file or die "Could not open '$local_file': $!";
 394             local $/;
 395             my $ystream = <FH>;
 396             my @yaml;
 397             eval { @yaml = $code->($ystream); };
 398             if ($@) {
 399                 # this shall not be done by the frontend
 400                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 401             }
 402             return \@yaml;
 403         }
 404     } else {
 405         # this shall not be done by the frontend
 406         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 407     }
 408     return +[];
 409 }
 410
 411 # CPAN::_yaml_dumpfile
 412 sub _yaml_dumpfile {
 413     my($self,$local_file,@what) = @_;
 414     my $yaml_module = _yaml_module;
 415     if ($CPAN::META->has_inst($yaml_module)) {
 416         my $code;
 417         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 418             $code = UNIVERSAL::can($yaml_module, "Dump");
 419             eval { print $local_file $code->(@what) };
 420         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 421             eval { $code->($local_file,@what); };
 422         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 423             local *FH;
 424             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 425             print FH $code->(@what);
 426         }
 427         if ($@) {
 428             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 429         }
 430     } else {
 431         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 432             # I think this case does not justify a warning at all
 433         } else {
 434             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 435         }
 436     }
 437 }
 438
 439 sub _init_sqlite () {
 440     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 441         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 442             unless $Have_warned->{"CPAN::SQLite"}++;
 443         return;
 444     }
 445     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 446     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 447 }
 448
 449 {
 450     my $negative_cache = {};
 451     sub _sqlite_running {
 452         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 453             # need to cache the result, otherwise too slow
 454             return $negative_cache->{fact};
 455         } else {
 456             $negative_cache = {}; # reset
 457         }
 458         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 459         return $ret if $ret; # fast anyway
 460         $negative_cache->{time} = time;
 461         return $negative_cache->{fact} = $ret;
 462     }
 463 }
 464
 465 package CPAN::CacheMgr;
 466 use strict;
 467 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 468 use File::Find;
 469
 470 package CPAN::FTP;
 471 use strict;
 472 use Fcntl qw(:flock);
 473 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 474 @CPAN::FTP::ISA = qw(CPAN::Debug);
 475
 476 package CPAN::LWP::UserAgent;
 477 use strict;
 478 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 479 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 480
 481 package CPAN::Complete;
 482 use strict;
 483 @CPAN::Complete::ISA = qw(CPAN::Debug);
 484 # Q: where is the "How do I add a new command" HOWTO?
 485 # A: svn diff -r 1048:1049 where andk added the report command
 486 @CPAN::Complete::COMMANDS = sort qw(
 487                                     ! a b d h i m o q r u
 488                                     autobundle
 489                                     clean
 490                                     cvs_import
 491                                     dump
 492                                     failed
 493                                     force
 494                                     fforce
 495                                     hosts
 496                                     install
 497                                     install_tested
 498                                     is_tested
 499                                     look
 500                                     ls
 501                                     make
 502                                     mkmyconfig
 503                                     notest
 504                                     perldoc
 505                                     readme
 506                                     recent
 507                                     recompile
 508                                     reload
 509                                     report
 510                                     scripts
 511                                     test
 512                                     upgrade
 513 );
 514
 515 package CPAN::Index;
 516 use strict;
 517 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 518 @CPAN::Index::ISA = qw(CPAN::Debug);
 519 $LAST_TIME ||= 0;
 520 $DATE_OF_03 ||= 0;
 521 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 522 sub PROTOCOL { 2.0 }
 523
 524 package CPAN::InfoObj;
 525 use strict;
 526 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 527
 528 package CPAN::Author;
 529 use strict;
 530 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 531
 532 package CPAN::Distribution;
 533 use strict;
 534 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 535
 536 package CPAN::Bundle;
 537 use strict;
 538 @CPAN::Bundle::ISA = qw(CPAN::Module);
 539
 540 package CPAN::Module;
 541 use strict;
 542 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 543
 544 package CPAN::Exception::RecursiveDependency;
 545 use strict;
 546 use overload '""' => "as_string";
 547
 548 # a module sees its distribution (no version)
 549 # a distribution sees its prereqs (which are module names) (usually with versions)
 550 # a bundle sees its module names and/or its distributions (no version)
 551
 552 sub new {
 553     my($class) = shift;
 554     my($deps) = shift;
 555     my @deps;
 556     my %seen;
 557     for my $dep (@$deps) {
 558         push @deps, $dep;
 559         last if $seen{$dep}++;
 560     }
 561     bless { deps => \@deps }, $class;
 562 }
 563
 564 sub as_string {
 565     my($self) = shift;
 566     "\nRecursive dependency detected:\n    " .
 567         join("\n => ", @{$self->{deps}}) .
 568             ".\nCannot continue.\n";
 569 }
 570
 571 package CPAN::Exception::yaml_not_installed;
 572 use strict;
 573 use overload '""' => "as_string";
 574
 575 sub new {
 576     my($class,$module,$file,$during) = @_;
 577     bless { module => $module, file => $file, during => $during }, $class;
 578 }
 579
 580 sub as_string {
 581     my($self) = shift;
 582     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 583 }
 584
 585 package CPAN::Exception::yaml_process_error;
 586 use strict;
 587 use overload '""' => "as_string";
 588
 589 sub new {
 590     my($class,$module,$file,$during,$error) = shift;
 591     bless { module => $module,
 592             file => $file,
 593             during => $during,
 594             error => $error }, $class;
 595 }
 596
 597 sub as_string {
 598     my($self) = shift;
 599     "Alert: While trying to $self->{during} YAML file\n".
 600         "  $self->{file}\n".
 601             "with '$self->{module}' the following error was encountered:\n".
 602                 "  $self->{error}\n";
 603 }
 604
 605 package CPAN::Prompt; use overload '""' => "as_string";
 606 use vars qw($prompt);
 607 $prompt = "cpan> ";
 608 $CPAN::CurrentCommandId ||= 0;
 609 sub new {
 610     bless {}, shift;
 611 }
 612 sub as_string {
 613     my $word = "cpan";
 614     unless ($CPAN::META->{LOCK}) {
 615         $word = "nolock_cpan";
 616     }
 617     if ($CPAN::Config->{commandnumber_in_prompt}) {
 618         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 619     } else {
 620         "$word> ";
 621     }
 622 }
 623
 624 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 625 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 626 # planned are things like age or quality
 627 sub new {
 628     my($class,%args) = @_;
 629     bless {
 630            %args
 631           }, $class;
 632 }
 633 sub as_string {
 634     my($self) = @_;
 635     $self->text;
 636 }
 637 sub text {
 638     my($self,$set) = @_;
 639     if (defined $set) {
 640         $self->{TEXT} = $set;
 641     }
 642     $self->{TEXT};
 643 }
 644
 645 package CPAN::Distrostatus;
 646 use overload '""' => "as_string",
 647     fallback => 1;
 648 sub new {
 649     my($class,$arg) = @_;
 650     bless {
 651            TEXT => $arg,
 652            FAILED => substr($arg,0,2) eq "NO",
 653            COMMANDID => $CPAN::CurrentCommandId,
 654            TIME => time,
 655           }, $class;
 656 }
 657 sub commandid { shift->{COMMANDID} }
 658 sub failed { shift->{FAILED} }
 659 sub text {
 660     my($self,$set) = @_;
 661     if (defined $set) {
 662         $self->{TEXT} = $set;
 663     }
 664     $self->{TEXT};
 665 }
 666 sub as_string {
 667     my($self) = @_;
 668     $self->text;
 669 }
 670
 671 package CPAN::Shell;
 672 use strict;
 673 use vars qw(
 674             $ADVANCED_QUERY
 675             $AUTOLOAD
 676             $COLOR_REGISTERED
 677             $autoload_recursion
 678             $reload
 679             @ISA
 680            );
 681 @CPAN::Shell::ISA = qw(CPAN::Debug);
 682 $COLOR_REGISTERED ||= 0;
 683
 684 {
 685     $autoload_recursion   ||= 0;
 686
 687     #-> sub CPAN::Shell::AUTOLOAD ;
 688     sub AUTOLOAD {
 689         $autoload_recursion++;
 690         my($l) = $AUTOLOAD;
 691         my $class = shift(@_);
 692         # warn "autoload[$l] class[$class]";
 693         $l =~ s/.*:://;
 694         if ($CPAN::Signal) {
 695             warn "Refusing to autoload '$l' while signal pending";
 696             $autoload_recursion--;
 697             return;
 698         }
 699         if ($autoload_recursion > 1) {
 700             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 701             warn "Refusing to autoload $fullcommand in recursion\n";
 702             $autoload_recursion--;
 703             return;
 704         }
 705         if ($l =~ /^w/) {
 706             # XXX needs to be reconsidered
 707             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 708                 CPAN::WAIT->$l(@_);
 709             } else {
 710                 $CPAN::Frontend->mywarn(qq{
 711 Commands starting with "w" require CPAN::WAIT to be installed.
 712 Please consider installing CPAN::WAIT to use the fulltext index.
 713 For this you just need to type
 714     install CPAN::WAIT
 715 });
 716             }
 717         } else {
 718             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 719                                     qq{Type ? for help.
 720 });
 721         }
 722         $autoload_recursion--;
 723     }
 724 }
 725
 726 package CPAN;
 727 use strict;
 728
 729 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 730
 731 # from here on only subs.
 732 ################################################################################
 733
 734 sub _perl_fingerprint {
 735     my($self,$other_fingerprint) = @_;
 736     my $dll = eval {OS2::DLLname()};
 737     my $mtime_dll = 0;
 738     if (defined $dll) {
 739         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 740     }
 741     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 742     my $this_fingerprint = {
 743                             '$^X' => $^X,
 744                             sitearchexp => $Config::Config{sitearchexp},
 745                             'mtime_$^X' => $mtime_perl,
 746                             'mtime_dll' => $mtime_dll,
 747                            };
 748     if ($other_fingerprint) {
 749         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 750             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 751         }
 752         # mandatory keys since 1.88_57
 753         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 754             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 755         }
 756         return 1;
 757     } else {
 758         return $this_fingerprint;
 759     }
 760 }
 761
 762 sub suggest_myconfig () {
 763   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 764         $CPAN::Frontend->myprint("You don't seem to have a user ".
 765                                  "configuration (MyConfig.pm) yet.\n");
 766         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 767                                               "user configuration now? (Y/n)",
 768                                               "yes");
 769         if($new =~ m{^y}i) {
 770             CPAN::Shell->mkmyconfig();
 771             return &checklock;
 772         } else {
 773             $CPAN::Frontend->mydie("OK, giving up.");
 774         }
 775     }
 776 }
 777
 778 #-> sub CPAN::all_objects ;
 779 sub all_objects {
 780     my($mgr,$class) = @_;
 781     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 782     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 783     CPAN::Index->reload;
 784     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 785 }
 786
 787 # Called by shell, not in batch mode. In batch mode I see no risk in
 788 # having many processes updating something as installations are
 789 # continually checked at runtime. In shell mode I suspect it is
 790 # unintentional to open more than one shell at a time
 791
 792 #-> sub CPAN::checklock ;
 793 sub checklock {
 794     my($self) = @_;
 795     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 796     if (-f $lockfile && -M _ > 0) {
 797         my $fh = FileHandle->new($lockfile) or
 798             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 799         my $otherpid  = <$fh>;
 800         my $otherhost = <$fh>;
 801         $fh->close;
 802         if (defined $otherpid && $otherpid) {
 803             chomp $otherpid;
 804         }
 805         if (defined $otherhost && $otherhost) {
 806             chomp $otherhost;
 807         }
 808         my $thishost  = hostname();
 809         if (defined $otherhost && defined $thishost &&
 810             $otherhost ne '' && $thishost ne '' &&
 811             $otherhost ne $thishost) {
 812             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 813                                            "reports other host $otherhost and other ".
 814                                            "process $otherpid.\n".
 815                                            "Cannot proceed.\n"));
 816         } elsif ($RUN_DEGRADED) {
 817             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 818         } elsif (defined $otherpid && $otherpid) {
 819             return if $$ == $otherpid; # should never happen
 820             $CPAN::Frontend->mywarn(
 821                                     qq{
 822 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 823 });
 824             if (kill 0, $otherpid) {
 825                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 826                 my($ans) =
 827                     CPAN::Shell::colorable_makemaker_prompt
 828                         (qq{Shall I try to run in degraded }.
 829                          qq{mode? (Y/n)},"y");
 830                 if ($ans =~ /^y/i) {
 831                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 832 Please report if something unexpected happens\n");
 833                     $RUN_DEGRADED = 1;
 834                     for ($CPAN::Config) {
 835                         # XXX
 836                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 837                         $_->{commandnumber_in_prompt} = 0; # visibility
 838                         $_->{histfile} = "";               # who should win otherwise?
 839                         $_->{cache_metadata} = 0;          # better would be a lock?
 840                         $_->{use_sqlite} = 0;              # better would be a write lock!
 841                     }
 842                 } else {
 843                     $CPAN::Frontend->mydie("
 844 You may want to kill the other job and delete the lockfile. On UNIX try:
 845     kill $otherpid
 846     rm $lockfile
 847 ");
 848                 }
 849             } elsif (-w $lockfile) {
 850                 my($ans) =
 851                     CPAN::Shell::colorable_makemaker_prompt
 852                         (qq{Other job not responding. Shall I overwrite }.
 853                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 854                 $CPAN::Frontend->myexit("Ok, bye\n")
 855                     unless $ans =~ /^y/i;
 856             } else {
 857                 Carp::croak(
 858                             qq{Lockfile '$lockfile' not writeable by you. }.
 859                             qq{Cannot proceed.\n}.
 860                             qq{    On UNIX try:\n}.
 861                             qq{    rm '$lockfile'\n}.
 862                             qq{  and then rerun us.\n}
 863                            );
 864             }
 865         } else {
 866             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 867                                            "'$lockfile', please remove. Cannot proceed.\n"));
 868         }
 869     }
 870     my $dotcpan = $CPAN::Config->{cpan_home};
 871     eval { File::Path::mkpath($dotcpan);};
 872     if ($@) {
 873         # A special case at least for Jarkko.
 874         my $firsterror = $@;
 875         my $seconderror;
 876         my $symlinkcpan;
 877         if (-l $dotcpan) {
 878             $symlinkcpan = readlink $dotcpan;
 879             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 880             eval { File::Path::mkpath($symlinkcpan); };
 881             if ($@) {
 882                 $seconderror = $@;
 883             } else {
 884                 $CPAN::Frontend->mywarn(qq{
 885 Working directory $symlinkcpan created.
 886 });
 887             }
 888         }
 889         unless (-d $dotcpan) {
 890             my $mess = qq{
 891 Your configuration suggests "$dotcpan" as your
 892 CPAN.pm working directory. I could not create this directory due
 893 to this error: $firsterror\n};
 894             $mess .= qq{
 895 As "$dotcpan" is a symlink to "$symlinkcpan",
 896 I tried to create that, but I failed with this error: $seconderror
 897 } if $seconderror;
 898             $mess .= qq{
 899 Please make sure the directory exists and is writable.
 900 };
 901             $CPAN::Frontend->myprint($mess);
 902             return suggest_myconfig;
 903         }
 904     } # $@ after eval mkpath $dotcpan
 905     if (0) { # to test what happens when a race condition occurs
 906         for (reverse 1..10) {
 907             print $_, "\n";
 908             sleep 1;
 909         }
 910     }
 911     # locking
 912     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 913         my $fh;
 914         unless ($fh = FileHandle->new("+>>$lockfile")) {
 915             if ($! =~ /Permission/) {
 916                 $CPAN::Frontend->myprint(qq{
 917
 918 Your configuration suggests that CPAN.pm should use a working
 919 directory of
 920     $CPAN::Config->{cpan_home}
 921 Unfortunately we could not create the lock file
 922     $lockfile
 923 due to permission problems.
 924
 925 Please make sure that the configuration variable
 926     \$CPAN::Config->{cpan_home}
 927 points to a directory where you can write a .lock file. You can set
 928 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
 929 \@INC path;
 930 });
 931                 return suggest_myconfig;
 932             }
 933         }
 934         my $sleep = 1;
 935         while (!flock $fh, LOCK_EX|LOCK_NB) {
 936             if ($sleep>10) {
 937                 $CPAN::Frontend->mydie("Giving up\n");
 938             }
 939             $CPAN::Frontend->mysleep($sleep++);
 940             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
 941         }
 942
 943         seek $fh, 0, 0;
 944         truncate $fh, 0;
 945         $fh->print($$, "\n");
 946         $fh->print(hostname(), "\n");
 947         $self->{LOCK} = $lockfile;
 948         $self->{LOCKFH} = $fh;
 949     }
 950     $SIG{TERM} = sub {
 951         my $sig = shift;
 952         &cleanup;
 953         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
 954     };
 955     $SIG{INT} = sub {
 956       # no blocks!!!
 957         my $sig = shift;
 958         &cleanup if $Signal;
 959         die "Got yet another signal" if $Signal > 1;
 960         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
 961         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
 962         $Signal++;
 963     };
 964
 965 #       From: Larry Wall <larry@wall.org>
 966 #       Subject: Re: deprecating SIGDIE
 967 #       To: perl5-porters@perl.org
 968 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
 969 #
 970 #       The original intent of __DIE__ was only to allow you to substitute one
 971 #       kind of death for another on an application-wide basis without respect
 972 #       to whether you were in an eval or not.  As a global backstop, it should
 973 #       not be used any more lightly (or any more heavily :-) than class
 974 #       UNIVERSAL.  Any attempt to build a general exception model on it should
 975 #       be politely squashed.  Any bug that causes every eval {} to have to be
 976 #       modified should be not so politely squashed.
 977 #
 978 #       Those are my current opinions.  It is also my optinion that polite
 979 #       arguments degenerate to personal arguments far too frequently, and that
 980 #       when they do, it's because both people wanted it to, or at least didn't
 981 #       sufficiently want it not to.
 982 #
 983 #       Larry
 984
 985     # global backstop to cleanup if we should really die
 986     $SIG{__DIE__} = \&cleanup;
 987     $self->debug("Signal handler set.") if $CPAN::DEBUG;
 988 }
 989
 990 #-> sub CPAN::DESTROY ;
 991 sub DESTROY {
 992     &cleanup; # need an eval?
 993 }
 994
 995 #-> sub CPAN::anycwd ;
 996 sub anycwd () {
 997     my $getcwd;
 998     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
 999     CPAN->$getcwd();
1000 }
1001
1002 #-> sub CPAN::cwd ;
1003 sub cwd {Cwd::cwd();}
1004
1005 #-> sub CPAN::getcwd ;
1006 sub getcwd {Cwd::getcwd();}
1007
1008 #-> sub CPAN::fastcwd ;
1009 sub fastcwd {Cwd::fastcwd();}
1010
1011 #-> sub CPAN::backtickcwd ;
1012 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1013
1014 #-> sub CPAN::find_perl ;
1015 sub find_perl {
1016     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1017     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1018     my $candidate = File::Spec->catfile($pwd,$^X);
1019     $perl ||= $candidate if MM->maybe_command($candidate);
1020
1021     unless ($perl) {
1022         my ($component,$perl_name);
1023       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1024             PATH_COMPONENT: foreach $component (File::Spec->path(),
1025                                                 $Config::Config{'binexp'}) {
1026                   next unless defined($component) && $component;
1027                   my($abs) = File::Spec->catfile($component,$perl_name);
1028                   if (MM->maybe_command($abs)) {
1029                       $perl = $abs;
1030                       last DIST_PERLNAME;
1031                   }
1032               }
1033           }
1034     }
1035
1036     return $perl;
1037 }
1038
1039
1040 #-> sub CPAN::exists ;
1041 sub exists {
1042     my($mgr,$class,$id) = @_;
1043     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1044     CPAN::Index->reload;
1045     ### Carp::croak "exists called without class argument" unless $class;
1046     $id ||= "";
1047     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1048     my $exists;
1049     if (CPAN::_sqlite_running) {
1050         $exists = (exists $META->{readonly}{$class}{$id} or
1051                    $CPAN::SQLite->set($class, $id));
1052     } else {
1053         $exists =  exists $META->{readonly}{$class}{$id};
1054     }
1055     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1056 }
1057
1058 #-> sub CPAN::delete ;
1059 sub delete {
1060   my($mgr,$class,$id) = @_;
1061   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1062   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1063 }
1064
1065 #-> sub CPAN::has_usable
1066 # has_inst is sometimes too optimistic, we should replace it with this
1067 # has_usable whenever a case is given
1068 sub has_usable {
1069     my($self,$mod,$message) = @_;
1070     return 1 if $HAS_USABLE->{$mod};
1071     my $has_inst = $self->has_inst($mod,$message);
1072     return unless $has_inst;
1073     my $usable;
1074     $usable = {
1075                LWP => [ # we frequently had "Can't locate object
1076                         # method "new" via package "LWP::UserAgent" at
1077                         # (eval 69) line 2006
1078                        sub {require LWP},
1079                        sub {require LWP::UserAgent},
1080                        sub {require HTTP::Request},
1081                        sub {require URI::URL},
1082                       ],
1083                'Net::FTP' => [
1084                             sub {require Net::FTP},
1085                             sub {require Net::Config},
1086                            ],
1087                'File::HomeDir' => [
1088                                    sub {require File::HomeDir;
1089                                         unless (File::HomeDir::->VERSION >= 0.52){
1090                                             for ("Will not use File::HomeDir, need 0.52\n") {
1091                                                 $CPAN::Frontend->mywarn($_);
1092                                                 die $_;
1093                                             }
1094                                         }
1095                                     },
1096                                   ],
1097                'Archive::Tar' => [
1098                                   sub {require Archive::Tar;
1099                                        unless (Archive::Tar::->VERSION >= 1.00) {
1100                                             for ("Will not use Archive::Tar, need 1.00\n") {
1101                                                 $CPAN::Frontend->mywarn($_);
1102                                                 die $_;
1103                                             }
1104                                        }
1105                                   },
1106                                  ],
1107               };
1108     if ($usable->{$mod}) {
1109         for my $c (0..$#{$usable->{$mod}}) {
1110             my $code = $usable->{$mod}[$c];
1111             my $ret = eval { &$code() };
1112             $ret = "" unless defined $ret;
1113             if ($@) {
1114                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1115                 return;
1116             }
1117         }
1118     }
1119     return $HAS_USABLE->{$mod} = 1;
1120 }
1121
1122 #-> sub CPAN::has_inst
1123 sub has_inst {
1124     my($self,$mod,$message) = @_;
1125     Carp::croak("CPAN->has_inst() called without an argument")
1126         unless defined $mod;
1127     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1128         keys %{$CPAN::Config->{dontload_hash}||{}},
1129             @{$CPAN::Config->{dontload_list}||[]};
1130     if (defined $message && $message eq "no"  # afair only used by Nox
1131         ||
1132         $dont{$mod}
1133        ) {
1134       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1135       return 0;
1136     }
1137     my $file = $mod;
1138     my $obj;
1139     $file =~ s|::|/|g;
1140     $file .= ".pm";
1141     if ($INC{$file}) {
1142         # checking %INC is wrong, because $INC{LWP} may be true
1143         # although $INC{"URI/URL.pm"} may have failed. But as
1144         # I really want to say "bla loaded OK", I have to somehow
1145         # cache results.
1146         ### warn "$file in %INC"; #debug
1147         return 1;
1148     } elsif (eval { require $file }) {
1149         # eval is good: if we haven't yet read the database it's
1150         # perfect and if we have installed the module in the meantime,
1151         # it tries again. The second require is only a NOOP returning
1152         # 1 if we had success, otherwise it's retrying
1153
1154         my $v = eval "\$$mod\::VERSION";
1155         $v = $v ? " (v$v)" : "";
1156         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1157         if ($mod eq "CPAN::WAIT") {
1158             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1159         }
1160         return 1;
1161     } elsif ($mod eq "Net::FTP") {
1162         $CPAN::Frontend->mywarn(qq{
1163   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1164   if you just type
1165       install Bundle::libnet
1166
1167 }) unless $Have_warned->{"Net::FTP"}++;
1168         $CPAN::Frontend->mysleep(3);
1169     } elsif ($mod eq "Digest::SHA"){
1170         if ($Have_warned->{"Digest::SHA"}++) {
1171             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1172                                      qq{because Digest::SHA not installed.\n});
1173         } else {
1174             $CPAN::Frontend->mywarn(qq{
1175   CPAN: checksum security checks disabled because Digest::SHA not installed.
1176   Please consider installing the Digest::SHA module.
1177
1178 });
1179             $CPAN::Frontend->mysleep(2);
1180         }
1181     } elsif ($mod eq "Module::Signature"){
1182         # NOT prefs_lookup, we are not a distro
1183         my $check_sigs = $CPAN::Config->{check_sigs};
1184         if (not $check_sigs) {
1185             # they do not want us:-(
1186         } elsif (not $Have_warned->{"Module::Signature"}++) {
1187             # No point in complaining unless the user can
1188             # reasonably install and use it.
1189             if (eval { require Crypt::OpenPGP; 1 } ||
1190                 (
1191                  defined $CPAN::Config->{'gpg'}
1192                  &&
1193                  $CPAN::Config->{'gpg'} =~ /\S/
1194                 )
1195                ) {
1196                 $CPAN::Frontend->mywarn(qq{
1197   CPAN: Module::Signature security checks disabled because Module::Signature
1198   not installed.  Please consider installing the Module::Signature module.
1199   You may also need to be able to connect over the Internet to the public
1200   keyservers like pgp.mit.edu (port 11371).
1201
1202 });
1203                 $CPAN::Frontend->mysleep(2);
1204             }
1205         }
1206     } else {
1207         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1208     }
1209     return 0;
1210 }
1211
1212 #-> sub CPAN::instance ;
1213 sub instance {
1214     my($mgr,$class,$id) = @_;
1215     CPAN::Index->reload;
1216     $id ||= "";
1217     # unsafe meta access, ok?
1218     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1219     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1220 }
1221
1222 #-> sub CPAN::new ;
1223 sub new {
1224     bless {}, shift;
1225 }
1226
1227 #-> sub CPAN::cleanup ;
1228 sub cleanup {
1229   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1230   local $SIG{__DIE__} = '';
1231   my($message) = @_;
1232   my $i = 0;
1233   my $ineval = 0;
1234   my($subroutine);
1235   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1236       $ineval = 1, last if
1237           $subroutine eq '(eval)';
1238   }
1239   return if $ineval && !$CPAN::End;
1240   return unless defined $META->{LOCK};
1241   return unless -f $META->{LOCK};
1242   $META->savehist;
1243   close $META->{LOCKFH};
1244   unlink $META->{LOCK};
1245   # require Carp;
1246   # Carp::cluck("DEBUGGING");
1247   if ( $CPAN::CONFIG_DIRTY ) {
1248       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1249   }
1250   $CPAN::Frontend->myprint("Lockfile removed.\n");
1251 }
1252
1253 #-> sub CPAN::readhist
1254 sub readhist {
1255     my($self,$term,$histfile) = @_;
1256     my($fh) = FileHandle->new;
1257     open $fh, "<$histfile" or last;
1258     local $/ = "\n";
1259     while (<$fh>) {
1260         chomp;
1261         $term->AddHistory($_);
1262     }
1263     close $fh;
1264 }
1265
1266 #-> sub CPAN::savehist
1267 sub savehist {
1268     my($self) = @_;
1269     my($histfile,$histsize);
1270     unless ($histfile = $CPAN::Config->{'histfile'}){
1271         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1272         return;
1273     }
1274     $histsize = $CPAN::Config->{'histsize'} || 100;
1275     if ($CPAN::term){
1276         unless ($CPAN::term->can("GetHistory")) {
1277             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1278             return;
1279         }
1280     } else {
1281         return;
1282     }
1283     my @h = $CPAN::term->GetHistory;
1284     splice @h, 0, @h-$histsize if @h>$histsize;
1285     my($fh) = FileHandle->new;
1286     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1287     local $\ = local $, = "\n";
1288     print $fh @h;
1289     close $fh;
1290 }
1291
1292 #-> sub CPAN::is_tested
1293 sub is_tested {
1294     my($self,$what,$when) = @_;
1295     unless ($what) {
1296         Carp::cluck("DEBUG: empty what");
1297         return;
1298     }
1299     $self->{is_tested}{$what} = $when;
1300 }
1301
1302 #-> sub CPAN::is_installed
1303 # unsets the is_tested flag: as soon as the thing is installed, it is
1304 # not needed in set_perl5lib anymore
1305 sub is_installed {
1306     my($self,$what) = @_;
1307     delete $self->{is_tested}{$what};
1308 }
1309
1310 sub _list_sorted_descending_is_tested {
1311     my($self) = @_;
1312     sort
1313         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1314             keys %{$self->{is_tested}}
1315 }
1316
1317 #-> sub CPAN::set_perl5lib
1318 sub set_perl5lib {
1319     my($self,$for) = @_;
1320     unless ($for) {
1321         (undef,undef,undef,$for) = caller(1);
1322         $for =~ s/.*://;
1323     }
1324     $self->{is_tested} ||= {};
1325     return unless %{$self->{is_tested}};
1326     my $env = $ENV{PERL5LIB};
1327     $env = $ENV{PERLLIB} unless defined $env;
1328     my @env;
1329     push @env, $env if defined $env and length $env;
1330     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1331     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1332
1333     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1334     if (@dirs < 12) {
1335         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1336     } elsif (@dirs < 24) {
1337         my @d = map {my $cp = $_;
1338                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1339                      $cp
1340                  } @dirs;
1341         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1342                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1343                                  "for '$for'\n"
1344                                 );
1345     } else {
1346         my $cnt = keys %{$self->{is_tested}};
1347         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1348                                  "$cnt build dirs to PERL5LIB; ".
1349                                  "for '$for'\n"
1350                                 );
1351     }
1352
1353     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1354 }
1355
1356 package CPAN::CacheMgr;
1357 use strict;
1358
1359 #-> sub CPAN::CacheMgr::as_string ;
1360 sub as_string {
1361     eval { require Data::Dumper };
1362     if ($@) {
1363         return shift->SUPER::as_string;
1364     } else {
1365         return Data::Dumper::Dumper(shift);
1366     }
1367 }
1368
1369 #-> sub CPAN::CacheMgr::cachesize ;
1370 sub cachesize {
1371     shift->{DU};
1372 }
1373
1374 #-> sub CPAN::CacheMgr::tidyup ;
1375 sub tidyup {
1376   my($self) = @_;
1377   return unless $CPAN::META->{LOCK};
1378   return unless -d $self->{ID};
1379   while ($self->{DU} > $self->{'MAX'} ) {
1380     my($toremove) = shift @{$self->{FIFO}};
1381     unless ($toremove =~ /\.yml$/) {
1382         $CPAN::Frontend->myprint(sprintf(
1383                                          "DEL(%.1f>%.1fMB): %s \n",
1384                                          $self->{DU},
1385                                          $self->{MAX},
1386                                          $toremove,
1387                                         )
1388                                 );
1389     }
1390     return if $CPAN::Signal;
1391     $self->_clean_cache($toremove);
1392     return if $CPAN::Signal;
1393   }
1394 }
1395
1396 #-> sub CPAN::CacheMgr::dir ;
1397 sub dir {
1398     shift->{ID};
1399 }
1400
1401 #-> sub CPAN::CacheMgr::entries ;
1402 sub entries {
1403     my($self,$dir) = @_;
1404     return unless defined $dir;
1405     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1406     $dir ||= $self->{ID};
1407     my($cwd) = CPAN::anycwd();
1408     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1409     my $dh = DirHandle->new(File::Spec->curdir)
1410         or Carp::croak("Couldn't opendir $dir: $!");
1411     my(@entries);
1412     for ($dh->read) {
1413         next if $_ eq "." || $_ eq "..";
1414         if (-f $_) {
1415             push @entries, File::Spec->catfile($dir,$_);
1416         } elsif (-d _) {
1417             push @entries, File::Spec->catdir($dir,$_);
1418         } else {
1419             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1420         }
1421     }
1422     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1423     sort { -M $b <=> -M $a} @entries;
1424 }
1425
1426 #-> sub CPAN::CacheMgr::disk_usage ;
1427 sub disk_usage {
1428     my($self,$dir) = @_;
1429     return if exists $self->{SIZE}{$dir};
1430     return if $CPAN::Signal;
1431     my($Du) = 0;
1432     if (-e $dir) {
1433         if (-d $dir) {
1434             unless (-x $dir) {
1435                 unless (chmod 0755, $dir) {
1436                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1437                                             "permission to change the permission; cannot ".
1438                                             "estimate disk usage of '$dir'\n");
1439                     $CPAN::Frontend->mysleep(5);
1440                     return;
1441                 }
1442             }
1443         } elsif (-f $dir) {
1444             # nothing to say, no matter what the permissions
1445         }
1446     } else {
1447         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1448         return;
1449     }
1450     find(
1451          sub {
1452            $File::Find::prune++ if $CPAN::Signal;
1453            return if -l $_;
1454            if ($^O eq 'MacOS') {
1455              require Mac::Files;
1456              my $cat  = Mac::Files::FSpGetCatInfo($_);
1457              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1458            } else {
1459              if (-d _) {
1460                unless (-x _) {
1461                  unless (chmod 0755, $_) {
1462                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1463                                            "the permission to change the permission; ".
1464                                            "can only partially estimate disk usage ".
1465                                            "of '$_'\n");
1466                    $CPAN::Frontend->mysleep(5);
1467                    return;
1468                  }
1469                }
1470              } else {
1471                $Du += (-s _);
1472              }
1473            }
1474          },
1475          $dir
1476         );
1477     return if $CPAN::Signal;
1478     $self->{SIZE}{$dir} = $Du/1024/1024;
1479     push @{$self->{FIFO}}, $dir;
1480     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1481     $self->{DU} += $Du/1024/1024;
1482     $self->{DU};
1483 }
1484
1485 #-> sub CPAN::CacheMgr::_clean_cache ;
1486 sub _clean_cache {
1487     my($self,$dir) = @_;
1488     return unless -e $dir;
1489     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1490             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1491         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1492                                 "will not remove\n");
1493         $CPAN::Frontend->mysleep(5);
1494         return;
1495     }
1496     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1497         if $CPAN::DEBUG;
1498     File::Path::rmtree($dir);
1499     my $id_deleted = 0;
1500     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1501         my $yaml_module = CPAN::_yaml_module;
1502         if ($CPAN::META->has_inst($yaml_module)) {
1503             my($peek_yaml) = CPAN->_yaml_loadfile("$dir.yml");
1504             if (my $id = $peek_yaml->[0]{distribution}{ID}) {
1505                 $CPAN::META->delete("CPAN::Distribution", $id);
1506                 # $CPAN::Frontend->mywarn (" +++\n");
1507                 $id_deleted++;
1508             }
1509         }
1510         unlink "$dir.yml"; # may fail
1511         unless ($id_deleted) {
1512             CPAN->debug("no distro found associated with '$dir'");
1513         }
1514     }
1515     $self->{DU} -= $self->{SIZE}{$dir};
1516     delete $self->{SIZE}{$dir};
1517 }
1518
1519 #-> sub CPAN::CacheMgr::new ;
1520 sub new {
1521     my $class = shift;
1522     my $time = time;
1523     my($debug,$t2);
1524     $debug = "";
1525     my $self = {
1526                 ID => $CPAN::Config->{build_dir},
1527                 MAX => $CPAN::Config->{'build_cache'},
1528                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1529                 DU => 0
1530                };
1531     File::Path::mkpath($self->{ID});
1532     my $dh = DirHandle->new($self->{ID});
1533     bless $self, $class;
1534     $self->scan_cache;
1535     $t2 = time;
1536     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1537     $time = $t2;
1538     CPAN->debug($debug) if $CPAN::DEBUG;
1539     $self;
1540 }
1541
1542 #-> sub CPAN::CacheMgr::scan_cache ;
1543 sub scan_cache {
1544     my $self = shift;
1545     return if $self->{SCAN} eq 'never';
1546     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1547         unless $self->{SCAN} eq 'atstart';
1548     return unless $CPAN::META->{LOCK};
1549     $CPAN::Frontend->myprint(
1550                              sprintf("Scanning cache %s for sizes\n",
1551                                      $self->{ID}));
1552     my $e;
1553     my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1554     my $i = 0;
1555     my $painted = 0;
1556     for $e (@entries) {
1557         # next if $e eq ".." || $e eq ".";
1558         $self->disk_usage($e);
1559         $i++;
1560         while (($painted/76) < ($i/@entries)) {
1561             $CPAN::Frontend->myprint(".");
1562             $painted++;
1563         }
1564         return if $CPAN::Signal;
1565     }
1566     $CPAN::Frontend->myprint("DONE\n");
1567     $self->tidyup;
1568 }
1569
1570 package CPAN::Shell;
1571 use strict;
1572
1573 #-> sub CPAN::Shell::h ;
1574 sub h {
1575     my($class,$about) = @_;
1576     if (defined $about) {
1577         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1578     } else {
1579         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1580         $CPAN::Frontend->myprint(qq{
1581 Display Information $filler (ver $CPAN::VERSION)
1582  command  argument          description
1583  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1584  i        WORD or /REGEXP/  about any of the above
1585  ls       AUTHOR or GLOB    about files in the author's directory
1586     (with WORD being a module, bundle or author name or a distribution
1587     name of the form AUTHOR/DISTRIBUTION)
1588
1589 Download, Test, Make, Install...
1590  get      download                     clean    make clean
1591  make     make (implies get)           look     open subshell in dist directory
1592  test     make test (implies make)     readme   display these README files
1593  install  make install (implies test)  perldoc  display POD documentation
1594
1595 Upgrade
1596  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1597  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1598
1599 Pragmas
1600  force  CMD    try hard to do command  fforce CMD    try harder
1601  notest CMD    skip testing
1602
1603 Other
1604  h,?           display this menu       ! perl-code   eval a perl command
1605  o conf [opt]  set and query options   q             quit the cpan shell
1606  reload cpan   load CPAN.pm again      reload index  load newer indices
1607  autobundle    Snapshot                recent        latest CPAN uploads});
1608 }
1609 }
1610
1611 *help = \&h;
1612
1613 #-> sub CPAN::Shell::a ;
1614 sub a {
1615   my($self,@arg) = @_;
1616   # authors are always UPPERCASE
1617   for (@arg) {
1618     $_ = uc $_ unless /=/;
1619   }
1620   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1621 }
1622
1623 #-> sub CPAN::Shell::globls ;
1624 sub globls {
1625     my($self,$s,$pragmas) = @_;
1626     # ls is really very different, but we had it once as an ordinary
1627     # command in the Shell (upto rev. 321) and we could not handle
1628     # force well then
1629     my(@accept,@preexpand);
1630     if ($s =~ /[\*\?\/]/) {
1631         if ($CPAN::META->has_inst("Text::Glob")) {
1632             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1633                 my $rau = Text::Glob::glob_to_regex(uc $au);
1634                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1635                       if $CPAN::DEBUG;
1636                 push @preexpand, map { $_->id . "/" . $pathglob }
1637                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1638             } else {
1639                 my $rau = Text::Glob::glob_to_regex(uc $s);
1640                 push @preexpand, map { $_->id }
1641                     CPAN::Shell->expand_by_method('CPAN::Author',
1642                                                   ['id'],
1643                                                   "/$rau/");
1644             }
1645         } else {
1646             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1647         }
1648     } else {
1649         push @preexpand, uc $s;
1650     }
1651     for (@preexpand) {
1652         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1653             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1654             next;
1655         }
1656         push @accept, $_;
1657     }
1658     my $silent = @accept>1;
1659     my $last_alpha = "";
1660     my @results;
1661     for my $a (@accept){
1662         my($author,$pathglob);
1663         if ($a =~ m|(.*?)/(.*)|) {
1664             my $a2 = $1;
1665             $pathglob = $2;
1666             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1667                                                     ['id'],
1668                                                     $a2)
1669                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1670         } else {
1671             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1672                                                     ['id'],
1673                                                     $a)
1674                 or $CPAN::Frontend->mydie("No author found for $a\n");
1675         }
1676         if ($silent) {
1677             my $alpha = substr $author->id, 0, 1;
1678             my $ad;
1679             if ($alpha eq $last_alpha) {
1680                 $ad = "";
1681             } else {
1682                 $ad = "[$alpha]";
1683                 $last_alpha = $alpha;
1684             }
1685             $CPAN::Frontend->myprint($ad);
1686         }
1687         for my $pragma (@$pragmas) {
1688             if ($author->can($pragma)) {
1689                 $author->$pragma();
1690             }
1691         }
1692         push @results, $author->ls($pathglob,$silent); # silent if
1693                                                        # more than one
1694                                                        # author
1695         for my $pragma (@$pragmas) {
1696             my $unpragma = "un$pragma";
1697             if ($author->can($unpragma)) {
1698                 $author->$unpragma();
1699             }
1700         }
1701     }
1702     @results;
1703 }
1704
1705 #-> sub CPAN::Shell::local_bundles ;
1706 sub local_bundles {
1707     my($self,@which) = @_;
1708     my($incdir,$bdir,$dh);
1709     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1710         my @bbase = "Bundle";
1711         while (my $bbase = shift @bbase) {
1712             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1713             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1714             if ($dh = DirHandle->new($bdir)) { # may fail
1715                 my($entry);
1716                 for $entry ($dh->read) {
1717                     next if $entry =~ /^\./;
1718                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1719                     if (-d File::Spec->catdir($bdir,$entry)){
1720                         push @bbase, "$bbase\::$entry";
1721                     } else {
1722                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1723                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1724                     }
1725                 }
1726             }
1727         }
1728     }
1729 }
1730
1731 #-> sub CPAN::Shell::b ;
1732 sub b {
1733     my($self,@which) = @_;
1734     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1735     $self->local_bundles;
1736     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1737 }
1738
1739 #-> sub CPAN::Shell::d ;
1740 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1741
1742 #-> sub CPAN::Shell::m ;
1743 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1744     my $self = shift;
1745     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1746 }
1747
1748 #-> sub CPAN::Shell::i ;
1749 sub i {
1750     my($self) = shift;
1751     my(@args) = @_;
1752     @args = '/./' unless @args;
1753     my(@result);
1754     for my $type (qw/Bundle Distribution Module/) {
1755         push @result, $self->expand($type,@args);
1756     }
1757     # Authors are always uppercase.
1758     push @result, $self->expand("Author", map { uc $_ } @args);
1759
1760     my $result = @result == 1 ?
1761         $result[0]->as_string :
1762             @result == 0 ?
1763                 "No objects found of any type for argument @args\n" :
1764                     join("",
1765                          (map {$_->as_glimpse} @result),
1766                          scalar @result, " items found\n",
1767                         );
1768     $CPAN::Frontend->myprint($result);
1769 }
1770
1771 #-> sub CPAN::Shell::o ;
1772
1773 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1774 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1775 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1776 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1777 sub o {
1778     my($self,$o_type,@o_what) = @_;
1779     $o_type ||= "";
1780     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1781     if ($o_type eq 'conf') {
1782         if (!@o_what) { # print all things, "o conf"
1783             my($k,$v);
1784             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1785             my @from;
1786             if (exists $INC{'CPAN/Config.pm'}) {
1787                 push @from, $INC{'CPAN/Config.pm'};
1788             }
1789             if (exists $INC{'CPAN/MyConfig.pm'}) {
1790                 push @from, $INC{'CPAN/MyConfig.pm'};
1791             }
1792             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1793             $CPAN::Frontend->myprint(":\n");
1794             for $k (sort keys %CPAN::HandleConfig::can) {
1795                 $v = $CPAN::HandleConfig::can{$k};
1796                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1797             }
1798             $CPAN::Frontend->myprint("\n");
1799             for $k (sort keys %$CPAN::Config) {
1800                 CPAN::HandleConfig->prettyprint($k);
1801             }
1802             $CPAN::Frontend->myprint("\n");
1803         } else {
1804             if (CPAN::HandleConfig->edit(@o_what)) {
1805             } else {
1806                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1807                                          qq{items\n\n});
1808             }
1809         }
1810     } elsif ($o_type eq 'debug') {
1811         my(%valid);
1812         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1813         if (@o_what) {
1814             while (@o_what) {
1815                 my($what) = shift @o_what;
1816                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1817                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1818                     next;
1819                 }
1820                 if ( exists $CPAN::DEBUG{$what} ) {
1821                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1822                 } elsif ($what =~ /^\d/) {
1823                     $CPAN::DEBUG = $what;
1824                 } elsif (lc $what eq 'all') {
1825                     my($max) = 0;
1826                     for (values %CPAN::DEBUG) {
1827                         $max += $_;
1828                     }
1829                     $CPAN::DEBUG = $max;
1830                 } else {
1831                     my($known) = 0;
1832                     for (keys %CPAN::DEBUG) {
1833                         next unless lc($_) eq lc($what);
1834                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1835                         $known = 1;
1836                     }
1837                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1838                         unless $known;
1839                 }
1840             }
1841         } else {
1842           my $raw = "Valid options for debug are ".
1843               join(", ",sort(keys %CPAN::DEBUG), 'all').
1844                   qq{ or a number. Completion works on the options. }.
1845                       qq{Case is ignored.};
1846           require Text::Wrap;
1847           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1848           $CPAN::Frontend->myprint("\n\n");
1849         }
1850         if ($CPAN::DEBUG) {
1851             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1852             my($k,$v);
1853             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1854                 $v = $CPAN::DEBUG{$k};
1855                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1856                     if $v & $CPAN::DEBUG;
1857             }
1858         } else {
1859             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1860         }
1861     } else {
1862         $CPAN::Frontend->myprint(qq{
1863 Known options:
1864   conf    set or get configuration variables
1865   debug   set or get debugging options
1866 });
1867     }
1868 }
1869
1870 # CPAN::Shell::paintdots_onreload
1871 sub paintdots_onreload {
1872     my($ref) = shift;
1873     sub {
1874         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1875             my($subr) = $1;
1876             ++$$ref;
1877             local($|) = 1;
1878             # $CPAN::Frontend->myprint(".($subr)");
1879             $CPAN::Frontend->myprint(".");
1880             if ($subr =~ /\bshell\b/i) {
1881                 # warn "debug[$_[0]]";
1882
1883                 # It would be nice if we could detect that a
1884                 # subroutine has actually changed, but for now we
1885                 # practically always set the GOTOSHELL global
1886
1887                 $CPAN::GOTOSHELL=1;
1888             }
1889             return;
1890         }
1891         warn @_;
1892     };
1893 }
1894
1895 #-> sub CPAN::Shell::hosts ;
1896 sub hosts {
1897     my($self) = @_;
1898     my $fullstats = CPAN::FTP->_ftp_statistics();
1899     my $history = $fullstats->{history} || [];
1900     my %S; # statistics
1901     while (my $last = pop @$history) {
1902         my $attempts = $last->{attempts} or next;
1903         my $start;
1904         if (@$attempts) {
1905             $start = $attempts->[-1]{start};
1906             if ($#$attempts > 0) {
1907                 for my $i (0..$#$attempts-1) {
1908                     my $url = $attempts->[$i]{url} or next;
1909                     $S{no}{$url}++;
1910                 }
1911             }
1912         } else {
1913             $start = $last->{start};
1914         }
1915         next unless $last->{thesiteurl}; # C-C? bad filenames?
1916         $S{start} = $start;
1917         $S{end} ||= $last->{end};
1918         my $dltime = $last->{end} - $start;
1919         my $dlsize = $last->{filesize} || 0;
1920         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
1921         my $s = $S{ok}{$url} ||= {};
1922         $s->{n}++;
1923         $s->{dlsize} ||= 0;
1924         $s->{dlsize} += $dlsize/1024;
1925         $s->{dltime} ||= 0;
1926         $s->{dltime} += $dltime;
1927     }
1928     my $res;
1929     for my $url (keys %{$S{ok}}) {
1930         next if $S{ok}{$url}{dltime} == 0; # div by zero
1931         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
1932                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
1933                              $url,
1934                             ];
1935     }
1936     for my $url (keys %{$S{no}}) {
1937         push @{$res->{no}}, [$S{no}{$url},
1938                              $url,
1939                             ];
1940     }
1941     my $R = ""; # report
1942     if ($S{start} && $S{end}) {
1943         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
1944         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
1945     }
1946     if ($res->{ok} && @{$res->{ok}}) {
1947         $R .= sprintf "\nSuccessful downloads:
1948    N       kB  secs      kB/s url\n";
1949         my $i = 20;
1950         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
1951             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
1952             last if --$i<=0;
1953         }
1954     }
1955     if ($res->{no} && @{$res->{no}}) {
1956         $R .= sprintf "\nUnsuccessful downloads:\n";
1957         my $i = 20;
1958         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
1959             $R .= sprintf "%4d %s\n", @$_;
1960             last if --$i<=0;
1961         }
1962     }
1963     $CPAN::Frontend->myprint($R);
1964 }
1965
1966 #-> sub CPAN::Shell::reload ;
1967 sub reload {
1968     my($self,$command,@arg) = @_;
1969     $command ||= "";
1970     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
1971     if ($command =~ /^cpan$/i) {
1972         my $redef = 0;
1973         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
1974         my $failed;
1975         my @relo = (
1976                     "CPAN.pm",
1977                     "CPAN/Debug.pm",
1978                     "CPAN/FirstTime.pm",
1979                     "CPAN/HandleConfig.pm",
1980                     "CPAN/Kwalify.pm",
1981                     "CPAN/Queue.pm",
1982                     "CPAN/Reporter.pm",
1983                     "CPAN/SQLite.pm",
1984                     "CPAN/Tarzip.pm",
1985                     "CPAN/Version.pm",
1986                    );
1987       MFILE: for my $f (@relo) {
1988             next unless exists $INC{$f};
1989             my $p = $f;
1990             $p =~ s/\.pm$//;
1991             $p =~ s|/|::|g;
1992             $CPAN::Frontend->myprint("($p");
1993             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
1994             $self->_reload_this($f) or $failed++;
1995             my $v = eval "$p\::->VERSION";
1996             $CPAN::Frontend->myprint("v$v)");
1997         }
1998         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
1999         if ($failed) {
2000             my $errors = $failed == 1 ? "error" : "errors";
2001             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2002                                     "this session.\n");
2003         }
2004     } elsif ($command =~ /^index$/i) {
2005       CPAN::Index->force_reload;
2006     } else {
2007       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2008 index    re-reads the index files\n});
2009     }
2010 }
2011
2012 # reload means only load again what we have loaded before
2013 #-> sub CPAN::Shell::_reload_this ;
2014 sub _reload_this {
2015     my($self,$f,$args) = @_;
2016     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2017     return 1 unless $INC{$f}; # we never loaded this, so we do not
2018                               # reload but say OK
2019     my $pwd = CPAN::anycwd();
2020     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2021     my($file);
2022     for my $inc (@INC) {
2023         $file = File::Spec->catfile($inc,split /\//, $f);
2024         last if -f $file;
2025         $file = "";
2026     }
2027     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2028     my @inc = @INC;
2029     unless ($file && -f $file) {
2030         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2031         $file = $INC{$f};
2032         unless (CPAN->has_inst("File::Basename")) {
2033             @inc = File::Basename::dirname($file);
2034         } else {
2035             # do we ever need this?
2036             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2037         }
2038     }
2039     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2040     unless (-f $file) {
2041         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2042         return;
2043     }
2044     my $mtime = (stat $file)[9];
2045     $reload->{$f} ||= $^T;
2046     my $must_reload = $mtime > $reload->{$f};
2047     $args ||= {};
2048     $must_reload ||= $args->{reloforce};
2049     if ($must_reload) {
2050         my $fh = FileHandle->new($file) or
2051             $CPAN::Frontend->mydie("Could not open $file: $!");
2052         local($/);
2053         local $^W = 1;
2054         my $content = <$fh>;
2055         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2056             if $CPAN::DEBUG;
2057         delete $INC{$f};
2058         local @INC = @inc;
2059         eval "require '$f'";
2060         if ($@){
2061             warn $@;
2062             return;
2063         }
2064         $reload->{$f} = time;
2065     } else {
2066         $CPAN::Frontend->myprint("__unchanged__");
2067     }
2068     return 1;
2069 }
2070
2071 #-> sub CPAN::Shell::mkmyconfig ;
2072 sub mkmyconfig {
2073     my($self, $cpanpm, %args) = @_;
2074     require CPAN::FirstTime;
2075     my $home = CPAN::HandleConfig::home;
2076     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2077         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2078     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2079     CPAN::HandleConfig::require_myconfig_or_config;
2080     $CPAN::Config ||= {};
2081     $CPAN::Config = {
2082         %$CPAN::Config,
2083         build_dir           =>  undef,
2084         cpan_home           =>  undef,
2085         keep_source_where   =>  undef,
2086         histfile            =>  undef,
2087     };
2088     CPAN::FirstTime::init($cpanpm, %args);
2089 }
2090
2091 #-> sub CPAN::Shell::_binary_extensions ;
2092 sub _binary_extensions {
2093     my($self) = shift @_;
2094     my(@result,$module,%seen,%need,$headerdone);
2095     for $module ($self->expand('Module','/./')) {
2096         my $file  = $module->cpan_file;
2097         next if $file eq "N/A";
2098         next if $file =~ /^Contact Author/;
2099         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2100         next if $dist->isa_perl;
2101         next unless $module->xs_file;
2102         local($|) = 1;
2103         $CPAN::Frontend->myprint(".");
2104         push @result, $module;
2105     }
2106 #    print join " | ", @result;
2107     $CPAN::Frontend->myprint("\n");
2108     return @result;
2109 }
2110
2111 #-> sub CPAN::Shell::recompile ;
2112 sub recompile {
2113     my($self) = shift @_;
2114     my($module,@module,$cpan_file,%dist);
2115     @module = $self->_binary_extensions();
2116     for $module (@module){  # we force now and compile later, so we
2117                             # don't do it twice
2118         $cpan_file = $module->cpan_file;
2119         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2120         $pack->force; #
2121         $dist{$cpan_file}++;
2122     }
2123     for $cpan_file (sort keys %dist) {
2124         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2125         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2126         $pack->install;
2127         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2128                            # stop a package from recompiling,
2129                            # e.g. IO-1.12 when we have perl5.003_10
2130     }
2131 }
2132
2133 #-> sub CPAN::Shell::scripts ;
2134 sub scripts {
2135     my($self, $arg) = @_;
2136     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2137
2138     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2139         unless ($CPAN::META->has_inst($req)) {
2140             $CPAN::Frontend->mywarn("  $req not available\n");
2141         }
2142     }
2143     my $p = HTML::LinkExtor->new();
2144     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2145     unless (-f $indexfile) {
2146         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2147     }
2148     $p->parse_file($indexfile);
2149     my @hrefs;
2150     my $qrarg;
2151     if ($arg =~ s|^/(.+)/$|$1|) {
2152         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2153     }
2154     for my $l ($p->links) {
2155         my $tag = shift @$l;
2156         next unless $tag eq "a";
2157         my %att = @$l;
2158         my $href = $att{href};
2159         next unless $href =~ s|^\.\./authors/id/./../||;
2160         if ($arg) {
2161             if ($qrarg) {
2162                 if ($href =~ $qrarg) {
2163                     push @hrefs, $href;
2164                 }
2165             } else {
2166                 if ($href =~ /\Q$arg\E/) {
2167                     push @hrefs, $href;
2168                 }
2169             }
2170         } else {
2171             push @hrefs, $href;
2172         }
2173     }
2174     # now filter for the latest version if there is more than one of a name
2175     my %stems;
2176     for (sort @hrefs) {
2177         my $href = $_;
2178         s/-v?\d.*//;
2179         my $stem = $_;
2180         $stems{$stem} ||= [];
2181         push @{$stems{$stem}}, $href;
2182     }
2183     for (sort keys %stems) {
2184         my $highest;
2185         if (@{$stems{$_}} > 1) {
2186             $highest = List::Util::reduce {
2187                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2188               } @{$stems{$_}};
2189         } else {
2190             $highest = $stems{$_}[0];
2191         }
2192         $CPAN::Frontend->myprint("$highest\n");
2193     }
2194 }
2195
2196 #-> sub CPAN::Shell::report ;
2197 sub report {
2198     my($self,@args) = @_;
2199     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2200         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2201     }
2202     local $CPAN::Config->{test_report} = 1;
2203     $self->force("test",@args); # force is there so that the test be
2204                                 # re-run (as documented)
2205 }
2206
2207 # compare with is_tested
2208 #-> sub CPAN::Shell::install_tested
2209 sub install_tested {
2210     my($self,@some) = @_;
2211     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2212         return if @some;
2213     CPAN::Index->reload;
2214
2215     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2216         my $yaml = "$b.yml";
2217         unless (-f $yaml){
2218             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2219             next;
2220         }
2221         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2222         my $id = $yaml_content->[0]{distribution}{ID};
2223         unless ($id){
2224             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2225             next;
2226         }
2227         my $do = CPAN::Shell->expandany($id);
2228         unless ($do){
2229             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2230             next;
2231         }
2232         unless ($do->{build_dir}) {
2233             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2234             next;
2235         }
2236         unless ($do->{build_dir} eq $b) {
2237             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2238             next;
2239         }
2240         push @some, $do;
2241     }
2242
2243     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2244         return unless @some;
2245
2246     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2247     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2248         return unless @some;
2249
2250     # @some = grep { not $_->uptodate } @some;
2251     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2252     #     return unless @some;
2253
2254     CPAN->debug("some[@some]");
2255     for my $d (@some) {
2256         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2257         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2258         $CPAN::Frontend->mysleep(1);
2259         $self->install($d);
2260     }
2261 }
2262
2263 #-> sub CPAN::Shell::upgrade ;
2264 sub upgrade {
2265     my($self,@args) = @_;
2266     $self->install($self->r(@args));
2267 }
2268
2269 #-> sub CPAN::Shell::_u_r_common ;
2270 sub _u_r_common {
2271     my($self) = shift @_;
2272     my($what) = shift @_;
2273     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2274     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2275           $what && $what =~ /^[aru]$/;
2276     my(@args) = @_;
2277     @args = '/./' unless @args;
2278     my(@result,$module,%seen,%need,$headerdone,
2279        $version_undefs,$version_zeroes);
2280     $version_undefs = $version_zeroes = 0;
2281     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2282     my @expand = $self->expand('Module',@args);
2283     my $expand = scalar @expand;
2284     if (0) { # Looks like noise to me, was very useful for debugging
2285              # for metadata cache
2286         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2287     }
2288   MODULE: for $module (@expand) {
2289         my $file  = $module->cpan_file;
2290         next MODULE unless defined $file; # ??
2291         $file =~ s|^./../||;
2292         my($latest) = $module->cpan_version;
2293         my($inst_file) = $module->inst_file;
2294         my($have);
2295         return if $CPAN::Signal;
2296         if ($inst_file){
2297             if ($what eq "a") {
2298                 $have = $module->inst_version;
2299             } elsif ($what eq "r") {
2300                 $have = $module->inst_version;
2301                 local($^W) = 0;
2302                 if ($have eq "undef"){
2303                     $version_undefs++;
2304                 } elsif ($have == 0){
2305                     $version_zeroes++;
2306                 }
2307                 next MODULE unless CPAN::Version->vgt($latest, $have);
2308 # to be pedantic we should probably say:
2309 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2310 # to catch the case where CPAN has a version 0 and we have a version undef
2311             } elsif ($what eq "u") {
2312                 next MODULE;
2313             }
2314         } else {
2315             if ($what eq "a") {
2316                 next MODULE;
2317             } elsif ($what eq "r") {
2318                 next MODULE;
2319             } elsif ($what eq "u") {
2320                 $have = "-";
2321             }
2322         }
2323         return if $CPAN::Signal; # this is sometimes lengthy
2324         $seen{$file} ||= 0;
2325         if ($what eq "a") {
2326             push @result, sprintf "%s %s\n", $module->id, $have;
2327         } elsif ($what eq "r") {
2328             push @result, $module->id;
2329             next MODULE if $seen{$file}++;
2330         } elsif ($what eq "u") {
2331             push @result, $module->id;
2332             next MODULE if $seen{$file}++;
2333             next MODULE if $file =~ /^Contact/;
2334         }
2335         unless ($headerdone++){
2336             $CPAN::Frontend->myprint("\n");
2337             $CPAN::Frontend->myprint(sprintf(
2338                                              $sprintf,
2339                                              "",
2340                                              "Package namespace",
2341                                              "",
2342                                              "installed",
2343                                              "latest",
2344                                              "in CPAN file"
2345                                             ));
2346         }
2347         my $color_on = "";
2348         my $color_off = "";
2349         if (
2350             $COLOR_REGISTERED
2351             &&
2352             $CPAN::META->has_inst("Term::ANSIColor")
2353             &&
2354             $module->description
2355            ) {
2356             $color_on = Term::ANSIColor::color("green");
2357             $color_off = Term::ANSIColor::color("reset");
2358         }
2359         $CPAN::Frontend->myprint(sprintf $sprintf,
2360                                  $color_on,
2361                                  $module->id,
2362                                  $color_off,
2363                                  $have,
2364                                  $latest,
2365                                  $file);
2366         $need{$module->id}++;
2367     }
2368     unless (%need) {
2369         if ($what eq "u") {
2370             $CPAN::Frontend->myprint("No modules found for @args\n");
2371         } elsif ($what eq "r") {
2372             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2373         }
2374     }
2375     if ($what eq "r") {
2376         if ($version_zeroes) {
2377             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2378             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2379                 qq{a version number of 0\n});
2380         }
2381         if ($version_undefs) {
2382             my $s_has = $version_undefs > 1 ? "s have" : " has";
2383             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2384                 qq{parseable version number\n});
2385         }
2386     }
2387     @result;
2388 }
2389
2390 #-> sub CPAN::Shell::r ;
2391 sub r {
2392     shift->_u_r_common("r",@_);
2393 }
2394
2395 #-> sub CPAN::Shell::u ;
2396 sub u {
2397     shift->_u_r_common("u",@_);
2398 }
2399
2400 #-> sub CPAN::Shell::failed ;
2401 sub failed {
2402     my($self,$only_id,$silent) = @_;
2403     my @failed;
2404   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2405         my $failed = "";
2406       NAY: for my $nosayer ( # order matters!
2407                             "unwrapped",
2408                             "writemakefile",
2409                             "signature_verify",
2410                             "make",
2411                             "make_test",
2412                             "install",
2413                             "make_clean",
2414                            ) {
2415             next unless exists $d->{$nosayer};
2416             next unless defined $d->{$nosayer};
2417             next unless (
2418                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2419                          $d->{$nosayer}->failed :
2420                          $d->{$nosayer} =~ /^NO/
2421                         );
2422             next NAY if $only_id && $only_id != (
2423                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2424                                                  ?
2425                                                  $d->{$nosayer}->commandid
2426                                                  :
2427                                                  $CPAN::CurrentCommandId
2428                                                 );
2429             $failed = $nosayer;
2430             last;
2431         }
2432         next DIST unless $failed;
2433         my $id = $d->id;
2434         $id =~ s|^./../||;
2435         #$print .= sprintf(
2436         #                  "  %-45s: %s %s\n",
2437         push @failed,
2438             (
2439              UNIVERSAL::can($d->{$failed},"failed") ?
2440              [
2441               $d->{$failed}->commandid,
2442               $id,
2443               $failed,
2444               $d->{$failed}->text,
2445               $d->{$failed}{TIME}||0,
2446              ] :
2447              [
2448               1,
2449               $id,
2450               $failed,
2451               $d->{$failed},
2452               0,
2453              ]
2454             );
2455     }
2456     my $scope;
2457     if ($only_id) {
2458         $scope = "this command";
2459     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2460         $scope = "this or a previous session";
2461         # it might be nice to have a section for previous session and
2462         # a second for this
2463     } else {
2464         $scope = "this session";
2465     }
2466     if (@failed) {
2467         my $print;
2468         my $debug = 0;
2469         if ($debug) {
2470             $print = join "",
2471                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2472                     sort { $a->[0] <=> $b->[0] } @failed;
2473         } else {
2474             $print = join "",
2475                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2476                     sort {
2477                         $a->[0] <=> $b->[0]
2478                             ||
2479                                 $a->[4] <=> $b->[4]
2480                        } @failed;
2481         }
2482         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2483     } elsif (!$only_id || !$silent) {
2484         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2485     }
2486 }
2487
2488 # XXX intentionally undocumented because completely bogus, unportable,
2489 # useless, etc.
2490
2491 #-> sub CPAN::Shell::status ;
2492 sub status {
2493     my($self) = @_;
2494     require Devel::Size;
2495     my $ps = FileHandle->new;
2496     open $ps, "/proc/$$/status";
2497     my $vm = 0;
2498     while (<$ps>) {
2499         next unless /VmSize:\s+(\d+)/;
2500         $vm = $1;
2501         last;
2502     }
2503     $CPAN::Frontend->mywarn(sprintf(
2504                                     "%-27s %6d\n%-27s %6d\n",
2505                                     "vm",
2506                                     $vm,
2507                                     "CPAN::META",
2508                                     Devel::Size::total_size($CPAN::META)/1024,
2509                                    ));
2510     for my $k (sort keys %$CPAN::META) {
2511         next unless substr($k,0,4) eq "read";
2512         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2513         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2514             warn sprintf "  %-25s %6d (keys: %6d)\n",
2515                 $k2,
2516                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2517                           scalar keys %{$CPAN::META->{$k}{$k2}};
2518         }
2519     }
2520 }
2521
2522 # compare with install_tested
2523 #-> sub CPAN::Shell::is_tested
2524 sub is_tested {
2525     my($self) = @_;
2526     CPAN::Index->reload;
2527     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2528         my $time;
2529         if ($CPAN::META->{is_tested}{$b}) {
2530             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2531         } else {
2532             $time = scalar localtime;
2533             $time =~ s/\S/?/g;
2534         }
2535         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2536     }
2537 }
2538
2539 #-> sub CPAN::Shell::autobundle ;
2540 sub autobundle {
2541     my($self) = shift;
2542     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2543     my(@bundle) = $self->_u_r_common("a",@_);
2544     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2545     File::Path::mkpath($todir);
2546     unless (-d $todir) {
2547         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2548         return;
2549     }
2550     my($y,$m,$d) =  (localtime)[5,4,3];
2551     $y+=1900;
2552     $m++;
2553     my($c) = 0;
2554     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2555     my($to) = File::Spec->catfile($todir,"$me.pm");
2556     while (-f $to) {
2557         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2558         $to = File::Spec->catfile($todir,"$me.pm");
2559     }
2560     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2561     $fh->print(
2562                "package Bundle::$me;\n\n",
2563                "\$VERSION = '0.01';\n\n",
2564                "1;\n\n",
2565                "__END__\n\n",
2566                "=head1 NAME\n\n",
2567                "Bundle::$me - Snapshot of installation on ",
2568                $Config::Config{'myhostname'},
2569                " on ",
2570                scalar(localtime),
2571                "\n\n=head1 SYNOPSIS\n\n",
2572                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2573                "=head1 CONTENTS\n\n",
2574                join("\n", @bundle),
2575                "\n\n=head1 CONFIGURATION\n\n",
2576                Config->myconfig,
2577                "\n\n=head1 AUTHOR\n\n",
2578                "This Bundle has been generated automatically ",
2579                "by the autobundle routine in CPAN.pm.\n",
2580               );
2581     $fh->close;
2582     $CPAN::Frontend->myprint("\nWrote bundle file
2583     $to\n\n");
2584 }
2585
2586 #-> sub CPAN::Shell::expandany ;
2587 sub expandany {
2588     my($self,$s) = @_;
2589     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2590     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2591         $s = CPAN::Distribution->normalize($s);
2592         return $CPAN::META->instance('CPAN::Distribution',$s);
2593         # Distributions spring into existence, not expand
2594     } elsif ($s =~ m|^Bundle::|) {
2595         $self->local_bundles; # scanning so late for bundles seems
2596                               # both attractive and crumpy: always
2597                               # current state but easy to forget
2598                               # somewhere
2599         return $self->expand('Bundle',$s);
2600     } else {
2601         return $self->expand('Module',$s)
2602             if $CPAN::META->exists('CPAN::Module',$s);
2603     }
2604     return;
2605 }
2606
2607 #-> sub CPAN::Shell::expand ;
2608 sub expand {
2609     my $self = shift;
2610     my($type,@args) = @_;
2611     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2612     my $class = "CPAN::$type";
2613     my $methods = ['id'];
2614     for my $meth (qw(name)) {
2615         next unless $class->can($meth);
2616         push @$methods, $meth;
2617     }
2618     $self->expand_by_method($class,$methods,@args);
2619 }
2620
2621 #-> sub CPAN::Shell::expand_by_method ;
2622 sub expand_by_method {
2623     my $self = shift;
2624     my($class,$methods,@args) = @_;
2625     my($arg,@m);
2626     for $arg (@args) {
2627         my($regex,$command);
2628         if ($arg =~ m|^/(.*)/$|) {
2629             $regex = $1;
2630         } elsif ($arg =~ m/=/) {
2631             $command = 1;
2632         }
2633         my $obj;
2634         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2635                     $class,
2636                     defined $regex ? $regex : "UNDEFINED",
2637                     defined $command ? $command : "UNDEFINED",
2638                    ) if $CPAN::DEBUG;
2639         if (defined $regex) {
2640             if (CPAN::_sqlite_running) {
2641                 $CPAN::SQLite->search($class, $regex);
2642             }
2643             for $obj (
2644                       $CPAN::META->all_objects($class)
2645                      ) {
2646                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2647                     # BUG, we got an empty object somewhere
2648                     require Data::Dumper;
2649                     CPAN->debug(sprintf(
2650                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2651                                         $obj,
2652                                         Data::Dumper::Dumper($obj)
2653                                        )) if $CPAN::DEBUG;
2654                     next;
2655                 }
2656                 for my $method (@$methods) {
2657                     my $match = eval {$obj->$method() =~ /$regex/i};
2658                     if ($@) {
2659                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2660                         $err ||= $@; # if we were too restrictive above
2661                         $CPAN::Frontend->mydie("$err\n");
2662                     } elsif ($match) {
2663                         push @m, $obj;
2664                         last;
2665                     }
2666                 }
2667             }
2668         } elsif ($command) {
2669             die "equal sign in command disabled (immature interface), ".
2670                 "you can set
2671  ! \$CPAN::Shell::ADVANCED_QUERY=1
2672 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2673 that may go away anytime.\n"
2674                     unless $ADVANCED_QUERY;
2675             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2676             my($matchcrit) = $criterion =~ m/^~(.+)/;
2677             for my $self (
2678                           sort
2679                           {$a->id cmp $b->id}
2680                           $CPAN::META->all_objects($class)
2681                          ) {
2682                 my $lhs = $self->$method() or next; # () for 5.00503
2683                 if ($matchcrit) {
2684                     push @m, $self if $lhs =~ m/$matchcrit/;
2685                 } else {
2686                     push @m, $self if $lhs eq $criterion;
2687                 }
2688             }
2689         } else {
2690             my($xarg) = $arg;
2691             if ( $class eq 'CPAN::Bundle' ) {
2692                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2693             } elsif ($class eq "CPAN::Distribution") {
2694                 $xarg = CPAN::Distribution->normalize($arg);
2695             } else {
2696                 $xarg =~ s/:+/::/g;
2697             }
2698             if ($CPAN::META->exists($class,$xarg)) {
2699                 $obj = $CPAN::META->instance($class,$xarg);
2700             } elsif ($CPAN::META->exists($class,$arg)) {
2701                 $obj = $CPAN::META->instance($class,$arg);
2702             } else {
2703                 next;
2704             }
2705             push @m, $obj;
2706         }
2707     }
2708     @m = sort {$a->id cmp $b->id} @m;
2709     if ( $CPAN::DEBUG ) {
2710         my $wantarray = wantarray;
2711         my $join_m = join ",", map {$_->id} @m;
2712         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2713     }
2714     return wantarray ? @m : $m[0];
2715 }
2716
2717 #-> sub CPAN::Shell::format_result ;
2718 sub format_result {
2719     my($self) = shift;
2720     my($type,@args) = @_;
2721     @args = '/./' unless @args;
2722     my(@result) = $self->expand($type,@args);
2723     my $result = @result == 1 ?
2724         $result[0]->as_string :
2725             @result == 0 ?
2726                 "No objects of type $type found for argument @args\n" :
2727                     join("",
2728                          (map {$_->as_glimpse} @result),
2729                          scalar @result, " items found\n",
2730                         );
2731     $result;
2732 }
2733
2734 #-> sub CPAN::Shell::report_fh ;
2735 {
2736     my $installation_report_fh;
2737     my $previously_noticed = 0;
2738
2739     sub report_fh {
2740         return $installation_report_fh if $installation_report_fh;
2741         if ($CPAN::META->has_inst("File::Temp")) {
2742             $installation_report_fh
2743                 = File::Temp->new(
2744                                   template => 'cpan_install_XXXX',
2745                                   suffix   => '.txt',
2746                                   unlink   => 0,
2747                                  );
2748         }
2749         unless ( $installation_report_fh ) {
2750             warn("Couldn't open installation report file; " .
2751                  "no report file will be generated."
2752                 ) unless $previously_noticed++;
2753         }
2754     }
2755 }
2756
2757
2758 # The only reason for this method is currently to have a reliable
2759 # debugging utility that reveals which output is going through which
2760 # channel. No, I don't like the colors ;-)
2761
2762 # to turn colordebugging on, write
2763 # cpan> o conf colorize_output 1
2764
2765 #-> sub CPAN::Shell::print_ornamented ;
2766 {
2767     my $print_ornamented_have_warned = 0;
2768     sub colorize_output {
2769         my $colorize_output = $CPAN::Config->{colorize_output};
2770         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2771             unless ($print_ornamented_have_warned++) {
2772                 # no myprint/mywarn within myprint/mywarn!
2773                 warn "Colorize_output is set to true but Term::ANSIColor is not
2774 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2775             }
2776             $colorize_output = 0;
2777         }
2778         return $colorize_output;
2779     }
2780 }
2781
2782
2783 #-> sub CPAN::Shell::print_ornamented ;
2784 sub print_ornamented {
2785     my($self,$what,$ornament) = @_;
2786     return unless defined $what;
2787
2788     local $| = 1; # Flush immediately
2789     if ( $CPAN::Be_Silent ) {
2790         print {report_fh()} $what;
2791         return;
2792     }
2793     my $swhat = "$what"; # stringify if it is an object
2794     if ($CPAN::Config->{term_is_latin}){
2795         # courtesy jhi:
2796         $swhat
2797             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2798     }
2799     if ($self->colorize_output) {
2800         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2801             # if you want to have this configurable, please file a bugreport
2802             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2803         }
2804         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2805         if ($@) {
2806             print "Term::ANSIColor rejects color[$ornament]: $@\n
2807 Please choose a different color (Hint: try 'o conf init /color/')\n";
2808         }
2809         print $color_on,
2810             $swhat,
2811                 Term::ANSIColor::color("reset");
2812     } else {
2813         print $swhat;
2814     }
2815 }
2816
2817 #-> sub CPAN::Shell::myprint ;
2818
2819 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2820 # where to use what! I think, we send everything to STDOUT and use
2821 # print for normal/good news and warn for news that need more
2822 # attention. Yes, this is our working contract for now.
2823 sub myprint {
2824     my($self,$what) = @_;
2825
2826     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2827 }
2828
2829 #-> sub CPAN::Shell::myexit ;
2830 sub myexit {
2831     my($self,$what) = @_;
2832     $self->myprint($what);
2833     exit;
2834 }
2835
2836 #-> sub CPAN::Shell::mywarn ;
2837 sub mywarn {
2838     my($self,$what) = @_;
2839     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2840 }
2841
2842 # only to be used for shell commands
2843 #-> sub CPAN::Shell::mydie ;
2844 sub mydie {
2845     my($self,$what) = @_;
2846     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2847
2848     # If it is the shell, we want that the following die to be silent,
2849     # but if it is not the shell, we would need a 'die $what'. We need
2850     # to take care that only shell commands use mydie. Is this
2851     # possible?
2852
2853     die "\n";
2854 }
2855
2856 # sub CPAN::Shell::colorable_makemaker_prompt ;
2857 sub colorable_makemaker_prompt {
2858     my($foo,$bar) = @_;
2859     if (CPAN::Shell->colorize_output) {
2860         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2861         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2862         print $color_on;
2863     }
2864     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2865     if (CPAN::Shell->colorize_output) {
2866         print Term::ANSIColor::color('reset');
2867     }
2868     return $ans;
2869 }
2870
2871 # use this only for unrecoverable errors!
2872 #-> sub CPAN::Shell::unrecoverable_error ;
2873 sub unrecoverable_error {
2874     my($self,$what) = @_;
2875     my @lines = split /\n/, $what;
2876     my $longest = 0;
2877     for my $l (@lines) {
2878         $longest = length $l if length $l > $longest;
2879     }
2880     $longest = 62 if $longest > 62;
2881     for my $l (@lines) {
2882         if ($l =~ /^\s*$/){
2883             $l = "\n";
2884             next;
2885         }
2886         $l = "==> $l";
2887         if (length $l < 66) {
2888             $l = pack "A66 A*", $l, "<==";
2889         }
2890         $l .= "\n";
2891     }
2892     unshift @lines, "\n";
2893     $self->mydie(join "", @lines);
2894 }
2895
2896 #-> sub CPAN::Shell::mysleep ;
2897 sub mysleep {
2898     my($self, $sleep) = @_;
2899     use Time::HiRes qw(sleep);
2900     sleep $sleep;
2901 }
2902
2903 #-> sub CPAN::Shell::setup_output ;
2904 sub setup_output {
2905     return if -t STDOUT;
2906     my $odef = select STDERR;
2907     $| = 1;
2908     select STDOUT;
2909     $| = 1;
2910     select $odef;
2911 }
2912
2913 #-> sub CPAN::Shell::rematein ;
2914 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
2915 sub rematein {
2916     my $self = shift;
2917     my($meth,@some) = @_;
2918     my @pragma;
2919     while($meth =~ /^(ff?orce|notest)$/) {
2920         push @pragma, $meth;
2921         $meth = shift @some or
2922             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
2923                                    "cannot continue");
2924     }
2925     setup_output();
2926     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
2927
2928     # Here is the place to set "test_count" on all involved parties to
2929     # 0. We then can pass this counter on to the involved
2930     # distributions and those can refuse to test if test_count > X. In
2931     # the first stab at it we could use a 1 for "X".
2932
2933     # But when do I reset the distributions to start with 0 again?
2934     # Jost suggested to have a random or cycling interaction ID that
2935     # we pass through. But the ID is something that is just left lying
2936     # around in addition to the counter, so I'd prefer to set the
2937     # counter to 0 now, and repeat at the end of the loop. But what
2938     # about dependencies? They appear later and are not reset, they
2939     # enter the queue but not its copy. How do they get a sensible
2940     # test_count?
2941
2942     my $needs_recursion_protection = "make|test|install";
2943
2944     # construct the queue
2945     my($s,@s,@qcopy);
2946   STHING: foreach $s (@some) {
2947         my $obj;
2948         if (ref $s) {
2949             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
2950             $obj = $s;
2951         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
2952         } elsif ($s =~ m|^/|) { # looks like a regexp
2953             if (substr($s,-1,1) eq ".") {
2954                 $obj = CPAN::Shell->expandany($s);
2955             } else {
2956                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
2957                                         "not supported.\nRejecting argument '$s'\n");
2958                 $CPAN::Frontend->mysleep(2);
2959                 next;
2960             }
2961         } elsif ($meth eq "ls") {
2962             $self->globls($s,\@pragma);
2963             next STHING;
2964         } else {
2965             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
2966             $obj = CPAN::Shell->expandany($s);
2967         }
2968         if (0) {
2969         } elsif (ref $obj) {
2970             if ($meth =~ /^($needs_recursion_protection)$/) {
2971                 # silly for look or dump
2972                 $obj->color_cmd_tmps(0,1);
2973             }
2974             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
2975             push @qcopy, $obj;
2976         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
2977             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
2978             if ($meth =~ /^(dump|ls)$/) {
2979                 $obj->$meth();
2980             } else {
2981                 $CPAN::Frontend->mywarn(
2982                                         join "",
2983                                         "Don't be silly, you can't $meth ",
2984                                         $obj->fullname,
2985                                         " ;-)\n"
2986                                        );
2987                 $CPAN::Frontend->mysleep(2);
2988             }
2989         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
2990             CPAN::InfoObj->dump($s);
2991         } else {
2992             $CPAN::Frontend
2993                 ->mywarn(qq{Warning: Cannot $meth $s, }.
2994                           qq{don't know what it is.
2995 Try the command
2996
2997     i /$s/
2998
2999 to find objects with matching identifiers.
3000 });
3001             $CPAN::Frontend->mysleep(2);
3002         }
3003     }
3004
3005     # queuerunner (please be warned: when I started to change the
3006     # queue to hold objects instead of names, I made one or two
3007     # mistakes and never found which. I reverted back instead)
3008     while (my $q = CPAN::Queue->first) {
3009         my $obj;
3010         my $s = $q->as_string;
3011         my $reqtype = $q->reqtype || "";
3012         $obj = CPAN::Shell->expandany($s);
3013         unless ($obj) {
3014             # don't know how this can happen, maybe we should panic,
3015             # but maybe we get a solution from the first user who hits
3016             # this unfortunate exception?
3017             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3018                                     "to an object. Skipping.\n");
3019             $CPAN::Frontend->mysleep(5);
3020             CPAN::Queue->delete_first($s);
3021             next;
3022         }
3023         $obj->{reqtype} ||= "";
3024         {
3025             # force debugging because CPAN::SQLite somehow delivers us
3026             # an empty object;
3027
3028             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3029
3030             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3031                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3032         }
3033         if ($obj->{reqtype}) {
3034             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3035                 $obj->{reqtype} = $reqtype;
3036                 if (
3037                     exists $obj->{install}
3038                     &&
3039                     (
3040                      UNIVERSAL::can($obj->{install},"failed") ?
3041                      $obj->{install}->failed :
3042                      $obj->{install} =~ /^NO/
3043                     )
3044                    ) {
3045                     delete $obj->{install};
3046                     $CPAN::Frontend->mywarn
3047                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3048                 }
3049             }
3050         } else {
3051             $obj->{reqtype} = $reqtype;
3052         }
3053
3054         for my $pragma (@pragma) {
3055             if ($pragma
3056                 &&
3057                 $obj->can($pragma)){
3058                 $obj->$pragma($meth);
3059             }
3060         }
3061         if (UNIVERSAL::can($obj, 'called_for')) {
3062             $obj->called_for($s);
3063         }
3064         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3065                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3066
3067         push @qcopy, $obj;
3068         if (! UNIVERSAL::can($obj,$meth)) {
3069             # Must never happen
3070             my $serialized = "";
3071             if (0) {
3072             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3073                 $serialized = YAML::Syck::Dump($obj);
3074             } elsif ($CPAN::META->has_inst("YAML")) {
3075                 $serialized = YAML::Dump($obj);
3076             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3077                 $serialized = Data::Dumper::Dumper($obj);
3078             } else {
3079                 require overload;
3080                 $serialized = overload::StrVal($obj);
3081             }
3082             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3083         } elsif ($obj->$meth()){
3084             CPAN::Queue->delete($s);
3085         } else {
3086             CPAN->debug("failed");
3087         }
3088
3089         $obj->undelay;
3090         for my $pragma (@pragma) {
3091             my $unpragma = "un$pragma";
3092             if ($obj->can($unpragma)) {
3093                 $obj->$unpragma();
3094             }
3095         }
3096         CPAN::Queue->delete_first($s);
3097     }
3098     if ($meth =~ /^($needs_recursion_protection)$/) {
3099         for my $obj (@qcopy) {
3100             $obj->color_cmd_tmps(0,0);
3101         }
3102     }
3103 }
3104
3105 #-> sub CPAN::Shell::recent ;
3106 sub recent {
3107   my($self) = @_;
3108
3109   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3110   return;
3111 }
3112
3113 {
3114     # set up the dispatching methods
3115     no strict "refs";
3116     for my $command (qw(
3117                         clean
3118                         cvs_import
3119                         dump
3120                         force
3121                         fforce
3122                         get
3123                         install
3124                         look
3125                         ls
3126                         make
3127                         notest
3128                         perldoc
3129                         readme
3130                         test
3131                        )) {
3132         *$command = sub { shift->rematein($command, @_); };
3133     }
3134 }
3135
3136 package CPAN::LWP::UserAgent;
3137 use strict;
3138
3139 sub config {
3140     return if $SETUPDONE;
3141     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3142         require LWP::UserAgent;
3143         @ISA = qw(Exporter LWP::UserAgent);
3144         $SETUPDONE++;
3145     } else {
3146         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3147     }
3148 }
3149
3150 sub get_basic_credentials {
3151     my($self, $realm, $uri, $proxy) = @_;
3152     if ($USER && $PASSWD) {
3153         return ($USER, $PASSWD);
3154     }
3155     if ( $proxy ) {
3156         ($USER,$PASSWD) = $self->get_proxy_credentials();
3157     } else {
3158         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3159     }
3160     return($USER,$PASSWD);
3161 }
3162
3163 sub get_proxy_credentials {
3164     my $self = shift;
3165     my ($user, $password);
3166     if ( defined $CPAN::Config->{proxy_user} &&
3167          defined $CPAN::Config->{proxy_pass}) {
3168         $user = $CPAN::Config->{proxy_user};
3169         $password = $CPAN::Config->{proxy_pass};
3170         return ($user, $password);
3171     }
3172     my $username_prompt = "\nProxy authentication needed!
3173  (Note: to permanently configure username and password run
3174    o conf proxy_user your_username
3175    o conf proxy_pass your_password
3176      )\nUsername:";
3177     ($user, $password) =
3178         _get_username_and_password_from_user($username_prompt);
3179     return ($user,$password);
3180 }
3181
3182 sub get_non_proxy_credentials {
3183     my $self = shift;
3184     my ($user,$password);
3185     if ( defined $CPAN::Config->{username} &&
3186          defined $CPAN::Config->{password}) {
3187         $user = $CPAN::Config->{username};
3188         $password = $CPAN::Config->{password};
3189         return ($user, $password);
3190     }
3191     my $username_prompt = "\nAuthentication needed!
3192      (Note: to permanently configure username and password run
3193        o conf username your_username
3194        o conf password your_password
3195      )\nUsername:";
3196
3197     ($user, $password) =
3198         _get_username_and_password_from_user($username_prompt);
3199     return ($user,$password);
3200 }
3201
3202 sub _get_username_and_password_from_user {
3203     my $username_message = shift;
3204     my ($username,$password);
3205
3206     ExtUtils::MakeMaker->import(qw(prompt));
3207     $username = prompt($username_message);
3208         if ($CPAN::META->has_inst("Term::ReadKey")) {
3209             Term::ReadKey::ReadMode("noecho");
3210         }
3211     else {
3212         $CPAN::Frontend->mywarn(
3213             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3214         );
3215     }
3216     $password = prompt("Password:");
3217
3218         if ($CPAN::META->has_inst("Term::ReadKey")) {
3219             Term::ReadKey::ReadMode("restore");
3220         }
3221         $CPAN::Frontend->myprint("\n\n");
3222     return ($username,$password);
3223 }
3224
3225 # mirror(): Its purpose is to deal with proxy authentication. When we
3226 # call SUPER::mirror, we relly call the mirror method in
3227 # LWP::UserAgent. LWP::UserAgent will then call
3228 # $self->get_basic_credentials or some equivalent and this will be
3229 # $self->dispatched to our own get_basic_credentials method.
3230
3231 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3232
3233 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3234 # although we have gone through our get_basic_credentials, the proxy
3235 # server refuses to connect. This could be a case where the username or
3236 # password has changed in the meantime, so I'm trying once again without
3237 # $USER and $PASSWD to give the get_basic_credentials routine another
3238 # chance to set $USER and $PASSWD.
3239
3240 # mirror(): Its purpose is to deal with proxy authentication. When we
3241 # call SUPER::mirror, we relly call the mirror method in
3242 # LWP::UserAgent. LWP::UserAgent will then call
3243 # $self->get_basic_credentials or some equivalent and this will be
3244 # $self->dispatched to our own get_basic_credentials method.
3245
3246 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3247
3248 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3249 # although we have gone through our get_basic_credentials, the proxy
3250 # server refuses to connect. This could be a case where the username or
3251 # password has changed in the meantime, so I'm trying once again without
3252 # $USER and $PASSWD to give the get_basic_credentials routine another
3253 # chance to set $USER and $PASSWD.
3254
3255 sub mirror {
3256     my($self,$url,$aslocal) = @_;
3257     my $result = $self->SUPER::mirror($url,$aslocal);
3258     if ($result->code == 407) {
3259         undef $USER;
3260         undef $PASSWD;
3261         $result = $self->SUPER::mirror($url,$aslocal);
3262     }
3263     $result;
3264 }
3265
3266 package CPAN::FTP;
3267 use strict;
3268
3269 #-> sub CPAN::FTP::ftp_statistics
3270 # if they want to rewrite, they need to pass in a filehandle
3271 sub _ftp_statistics {
3272     my($self,$fh) = @_;
3273     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3274     $fh ||= FileHandle->new;
3275     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3276     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3277     my $sleep = 1;
3278     my $waitstart;
3279     while (!flock $fh, $locktype|LOCK_NB) {
3280         $waitstart ||= localtime();
3281         if ($sleep>3) {
3282             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3283         }
3284         $CPAN::Frontend->mysleep($sleep);
3285         if ($sleep <= 3) {
3286             $sleep+=0.33;
3287         } elsif ($sleep <=6) {
3288             $sleep+=0.11;
3289         }
3290     }
3291     my $stats = eval { CPAN->_yaml_loadfile($file); };
3292     if ($@) {
3293         if (ref $@) {
3294             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3295                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3296                 return;
3297             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3298                 $CPAN::Frontend->mydie($@);
3299             }
3300         } else {
3301             $CPAN::Frontend->mydie($@);
3302         }
3303     }
3304     return $stats->[0];
3305 }
3306
3307 #-> sub CPAN::FTP::_mytime
3308 sub _mytime () {
3309     if (CPAN->has_inst("Time::HiRes")) {
3310         return Time::HiRes::time();
3311     } else {
3312         return time;
3313     }
3314 }
3315
3316 #-> sub CPAN::FTP::_new_stats
3317 sub _new_stats {
3318     my($self,$file) = @_;
3319     my $ret = {
3320                file => $file,
3321                attempts => [],
3322                start => _mytime,
3323               };
3324     $ret;
3325 }
3326
3327 #-> sub CPAN::FTP::_add_to_statistics
3328 sub _add_to_statistics {
3329     my($self,$stats) = @_;
3330     my $yaml_module = CPAN::_yaml_module;
3331     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3332     if ($CPAN::META->has_inst($yaml_module)) {
3333         $stats->{thesiteurl} = $ThesiteURL;
3334         if (CPAN->has_inst("Time::HiRes")) {
3335             $stats->{end} = Time::HiRes::time();
3336         } else {
3337             $stats->{end} = time;
3338         }
3339         my $fh = FileHandle->new;
3340         my $time = time;
3341         my $sdebug = 0;
3342         my @debug;
3343         @debug = $time if $sdebug;
3344         my $fullstats = $self->_ftp_statistics($fh);
3345         close $fh;
3346         $fullstats->{history} ||= [];
3347         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3348         push @debug, time if $sdebug;
3349         push @{$fullstats->{history}}, $stats;
3350         # arbitrary hardcoded constants until somebody demands to have
3351         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3352         # YAML::Syck 0.82 has no noticable performance problem with 999;
3353         while (
3354                @{$fullstats->{history}} > 99
3355                || $time - $fullstats->{history}[0]{start} > 14*86400
3356               ) {
3357             shift @{$fullstats->{history}}
3358         }
3359         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3360         push @debug, time if $sdebug;
3361         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3362         # need no eval because if this fails, it is serious
3363         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3364         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3365         if ( $sdebug||$CPAN::DEBUG ) {
3366             local $CPAN::DEBUG = 512; # FTP
3367             push @debug, time;
3368             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3369                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3370                                 @debug,
3371                                ));
3372         }
3373         # Win32 cannot rename a file to an existing filename
3374         unlink($sfile) if ($^O eq 'MSWin32');
3375         rename "$sfile.$$", $sfile
3376             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3377     }
3378 }
3379
3380 # if file is CHECKSUMS, suggest the place where we got the file to be
3381 # checked from, maybe only for young files?
3382 #-> sub CPAN::FTP::_recommend_url_for
3383 sub _recommend_url_for {
3384     my($self, $file) = @_;
3385     my $urllist = $self->_get_urllist;
3386     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3387         my $fullstats = $self->_ftp_statistics();
3388         my $history = $fullstats->{history} || [];
3389         while (my $last = pop @$history) {
3390             last if $last->{end} - time > 3600; # only young results are interesting
3391             next unless $last->{file}; # dirname of nothing dies!
3392             next unless $file eq File::Basename::dirname($last->{file});
3393             return $last->{thesiteurl};
3394         }
3395     }
3396     if ($CPAN::Config->{randomize_urllist}
3397         &&
3398         rand(1) < $CPAN::Config->{randomize_urllist}
3399        ) {
3400         $urllist->[int rand scalar @$urllist];
3401     } else {
3402         return ();
3403     }
3404 }
3405
3406 #-> sub CPAN::FTP::_get_urllist
3407 sub _get_urllist {
3408     my($self) = @_;
3409     $CPAN::Config->{urllist} ||= [];
3410     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3411         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3412         $CPAN::Config->{urllist} = [];
3413     }
3414     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3415     for my $u (@urllist) {
3416         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3417         if (UNIVERSAL::can($u,"text")) {
3418             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3419         } else {
3420             $u .= "/" unless substr($u,-1) eq "/";
3421             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3422         }
3423     }
3424     \@urllist;
3425 }
3426
3427 #-> sub CPAN::FTP::ftp_get ;
3428 sub ftp_get {
3429     my($class,$host,$dir,$file,$target) = @_;
3430     $class->debug(
3431                   qq[Going to fetch file [$file] from dir [$dir]
3432         on host [$host] as local [$target]\n]
3433                  ) if $CPAN::DEBUG;
3434     my $ftp = Net::FTP->new($host);
3435     unless ($ftp) {
3436         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3437         return;
3438     }
3439     return 0 unless defined $ftp;
3440     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3441     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3442     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3443         my $msg = $ftp->message;
3444         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3445         return;
3446     }
3447     unless ( $ftp->cwd($dir) ){
3448         my $msg = $ftp->message;
3449         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3450         return;
3451     }
3452     $ftp->binary;
3453     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3454     unless ( $ftp->get($file,$target) ){
3455         my $msg = $ftp->message;
3456         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3457         return;
3458     }
3459     $ftp->quit; # it's ok if this fails
3460     return 1;
3461 }
3462
3463 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3464
3465  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3466  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3467  # > ***************
3468  # > *** 1562,1567 ****
3469  # > --- 1562,1580 ----
3470  # >       return 1 if substr($url,0,4) eq "file";
3471  # >       return 1 unless $url =~ m|://([^/]+)|;
3472  # >       my $host = $1;
3473  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3474  # > +     if ($proxy) {
3475  # > +         $proxy =~ m|://([^/:]+)|;
3476  # > +         $proxy = $1;
3477  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3478  # > +         if ($noproxy) {
3479  # > +             if ($host !~ /$noproxy$/) {
3480  # > +                 $host = $proxy;
3481  # > +             }
3482  # > +         } else {
3483  # > +             $host = $proxy;
3484  # > +         }
3485  # > +     }
3486  # >       require Net::Ping;
3487  # >       return 1 unless $Net::Ping::VERSION >= 2;
3488  # >       my $p;
3489
3490
3491 #-> sub CPAN::FTP::localize ;
3492 sub localize {
3493     my($self,$file,$aslocal,$force) = @_;
3494     $force ||= 0;
3495     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3496         unless defined $aslocal;
3497     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3498         if $CPAN::DEBUG;
3499
3500     if ($^O eq 'MacOS') {
3501         # Comment by AK on 2000-09-03: Uniq short filenames would be
3502         # available in CHECKSUMS file
3503         my($name, $path) = File::Basename::fileparse($aslocal, '');
3504         if (length($name) > 31) {
3505             $name =~ s/(
3506                         \.(
3507                            readme(\.(gz|Z))? |
3508                            (tar\.)?(gz|Z) |
3509                            tgz |
3510                            zip |
3511                            pm\.(gz|Z)
3512                           )
3513                        )$//x;
3514             my $suf = $1;
3515             my $size = 31 - length($suf);
3516             while (length($name) > $size) {
3517                 chop $name;
3518             }
3519             $name .= $suf;
3520             $aslocal = File::Spec->catfile($path, $name);
3521         }
3522     }
3523
3524     if (-f $aslocal && -r _ && !($force & 1)){
3525         my $size;
3526         if ($size = -s $aslocal) {
3527             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3528             return $aslocal;
3529         } else {
3530             # empty file from a previous unsuccessful attempt to download it
3531             unlink $aslocal or
3532                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3533                                        "could not remove.");
3534         }
3535     }
3536     my($maybe_restore) = 0;
3537     if (-f $aslocal){
3538         rename $aslocal, "$aslocal.bak$$";
3539         $maybe_restore++;
3540     }
3541
3542     my($aslocal_dir) = File::Basename::dirname($aslocal);
3543     File::Path::mkpath($aslocal_dir);
3544     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3545         qq{directory "$aslocal_dir".
3546     I\'ll continue, but if you encounter problems, they may be due
3547     to insufficient permissions.\n}) unless -w $aslocal_dir;
3548
3549     # Inheritance is not easier to manage than a few if/else branches
3550     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3551         unless ($Ua) {
3552             CPAN::LWP::UserAgent->config;
3553             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3554             if ($@) {
3555                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3556                     if $CPAN::DEBUG;
3557             } else {
3558                 my($var);
3559                 $Ua->proxy('ftp',  $var)
3560                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3561                 $Ua->proxy('http', $var)
3562                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3563
3564
3565 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3566 #
3567 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3568 #  > use ones that require basic autorization.
3569 #
3570 #  > Example of when I use it manually in my own stuff:
3571 #
3572 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3573 #  > $req->proxy_authorization_basic("username","password");
3574 #  > $res = $ua->request($req);
3575 #
3576
3577                 $Ua->no_proxy($var)
3578                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3579             }
3580         }
3581     }
3582     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3583         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3584     }
3585
3586     # Try the list of urls for each single object. We keep a record
3587     # where we did get a file from
3588     my(@reordered,$last);
3589     my $ccurllist = $self->_get_urllist;
3590     $last = $#$ccurllist;
3591     if ($force & 2) { # local cpans probably out of date, don't reorder
3592         @reordered = (0..$last);
3593     } else {
3594         @reordered =
3595             sort {
3596                 (substr($ccurllist->[$b],0,4) eq "file")
3597                     <=>
3598                 (substr($ccurllist->[$a],0,4) eq "file")
3599                     or
3600                 defined($ThesiteURL)
3601                     and
3602                 ($ccurllist->[$b] eq $ThesiteURL)
3603                     <=>
3604                 ($ccurllist->[$a] eq $ThesiteURL)
3605             } 0..$last;
3606     }
3607     my(@levels);
3608     $Themethod ||= "";
3609     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3610     if ($Themethod) {
3611         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3612     } else {
3613         @levels = qw/easy hard hardest/;
3614     }
3615     @levels = qw/easy/ if $^O eq 'MacOS';
3616     my($levelno);
3617     local $ENV{FTP_PASSIVE} =
3618         exists $CPAN::Config->{ftp_passive} ?
3619         $CPAN::Config->{ftp_passive} : 1;
3620     my $ret;
3621     my $stats = $self->_new_stats($file);
3622   LEVEL: for $levelno (0..$#levels) {
3623         my $level = $levels[$levelno];
3624         my $method = "host$level";
3625         my @host_seq = $level eq "easy" ?
3626             @reordered : 0..$last;  # reordered has CDROM up front
3627         my @urllist = map { $ccurllist->[$_] } @host_seq;
3628         for my $u (@CPAN::Defaultsites) {
3629             push @urllist, $u unless grep { $_ eq $u } @urllist;
3630         }
3631         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3632         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3633         if (my $recommend = $self->_recommend_url_for($file)) {
3634             @urllist = grep { $_ ne $recommend } @urllist;
3635             unshift @urllist, $recommend;
3636         }
3637         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3638         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3639         if ($ret) {
3640             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3641             if ($ret eq $aslocal_tempfile) {
3642                 # if we got it exactly as we asked for, only then we
3643                 # want to rename
3644                 rename $aslocal_tempfile, $aslocal
3645                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3646                                               "'$ret' to '$aslocal': $!");
3647                 $ret = $aslocal;
3648             }
3649             $Themethod = $level;
3650             my $now = time;
3651             # utime $now, $now, $aslocal; # too bad, if we do that, we
3652                                           # might alter a local mirror
3653             $self->debug("level[$level]") if $CPAN::DEBUG;
3654             last LEVEL;
3655         } else {
3656             unlink $aslocal_tempfile;
3657             last if $CPAN::Signal; # need to cleanup
3658         }
3659     }
3660     if ($ret) {
3661         $stats->{filesize} = -s $ret;
3662     }
3663     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3664     $self->_add_to_statistics($stats);
3665     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3666     if ($ret) {
3667         unlink "$aslocal.bak$$";
3668         return $ret;
3669     }
3670     unless ($CPAN::Signal) {
3671         my(@mess);
3672         local $" = " ";
3673         if (@{$CPAN::Config->{urllist}}) {
3674             push @mess,
3675                 qq{Please check, if the URLs I found in your configuration file \(}.
3676                     join(", ", @{$CPAN::Config->{urllist}}).
3677                         qq{\) are valid.};
3678         } else {
3679             push @mess, qq{Your urllist is empty!};
3680         }
3681         push @mess, qq{The urllist can be edited.},
3682             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3683         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3684         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3685         $CPAN::Frontend->mysleep(2);
3686     }
3687     if ($maybe_restore) {
3688         rename "$aslocal.bak$$", $aslocal;
3689         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3690                                  $self->ls($aslocal));
3691         return $aslocal;
3692     }
3693     return;
3694 }
3695
3696 sub _set_attempt {
3697     my($self,$stats,$method,$url) = @_;
3698     push @{$stats->{attempts}}, {
3699                                  method => $method,
3700                                  start => _mytime,
3701                                  url => $url,
3702                                 };
3703 }
3704
3705 # package CPAN::FTP;
3706 sub hosteasy {
3707     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3708     my($ro_url);
3709   HOSTEASY: for $ro_url (@$host_seq) {
3710         $self->_set_attempt($stats,"easy",$ro_url);
3711         my $url .= "$ro_url$file";
3712         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3713         if ($url =~ /^file:/) {
3714             my $l;
3715             if ($CPAN::META->has_inst('URI::URL')) {
3716                 my $u =  URI::URL->new($url);
3717                 $l = $u->path;
3718             } else { # works only on Unix, is poorly constructed, but
3719                 # hopefully better than nothing.
3720                 # RFC 1738 says fileurl BNF is
3721                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3722                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3723                 # the code
3724                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3725                 $l =~ s|^file:||;                   # assume they
3726                                                     # meant
3727                                                     # file://localhost
3728                 $l =~ s|^/||s
3729                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3730             }
3731             $self->debug("local file[$l]") if $CPAN::DEBUG;
3732             if ( -f $l && -r _) {
3733                 $ThesiteURL = $ro_url;
3734                 return $l;
3735             }
3736             if ($l =~ /(.+)\.gz$/) {
3737                 my $ungz = $1;
3738                 if ( -f $ungz && -r _) {
3739                     $ThesiteURL = $ro_url;
3740                     return $ungz;
3741                 }
3742             }
3743             # Maybe mirror has compressed it?
3744             if (-f "$l.gz") {
3745                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3746                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3747                 if ( -f $aslocal) {
3748                     $ThesiteURL = $ro_url;
3749                     return $aslocal;
3750                 }
3751             }
3752         }
3753         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3754         if ($CPAN::META->has_usable('LWP')) {
3755             $CPAN::Frontend->myprint("Fetching with LWP:
3756   $url
3757 ");
3758             unless ($Ua) {
3759                 CPAN::LWP::UserAgent->config;
3760                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3761                 if ($@) {
3762                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3763                 }
3764             }
3765             my $res = $Ua->mirror($url, $aslocal);
3766             if ($res->is_success) {
3767                 $ThesiteURL = $ro_url;
3768                 my $now = time;
3769                 utime $now, $now, $aslocal; # download time is more
3770                                             # important than upload
3771                                             # time
3772                 return $aslocal;
3773             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3774                 my $gzurl = "$url.gz";
3775                 $CPAN::Frontend->myprint("Fetching with LWP:
3776   $gzurl
3777 ");
3778                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3779                 if ($res->is_success) {
3780                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3781                         $ThesiteURL = $ro_url;
3782                         return $aslocal;
3783                     }
3784                 }
3785             } else {
3786                 $CPAN::Frontend->myprint(sprintf(
3787                                                  "LWP failed with code[%s] message[%s]\n",
3788                                                  $res->code,
3789                                                  $res->message,
3790                                                 ));
3791                 # Alan Burlison informed me that in firewall environments
3792                 # Net::FTP can still succeed where LWP fails. So we do not
3793                 # skip Net::FTP anymore when LWP is available.
3794             }
3795         } else {
3796             $CPAN::Frontend->mywarn("  LWP not available\n");
3797         }
3798         return if $CPAN::Signal;
3799         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3800             # that's the nice and easy way thanks to Graham
3801             $self->debug("recognized ftp") if $CPAN::DEBUG;
3802             my($host,$dir,$getfile) = ($1,$2,$3);
3803             if ($CPAN::META->has_usable('Net::FTP')) {
3804                 $dir =~ s|/+|/|g;
3805                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3806   $url
3807 ");
3808                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3809                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3810                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3811                     $ThesiteURL = $ro_url;
3812                     return $aslocal;
3813                 }
3814                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3815                     my $gz = "$aslocal.gz";
3816                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3817   $url.gz
3818 ");
3819                     if (CPAN::FTP->ftp_get($host,
3820                                            $dir,
3821                                            "$getfile.gz",
3822                                            $gz) &&
3823                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3824                        ){
3825                         $ThesiteURL = $ro_url;
3826                         return $aslocal;
3827                     }
3828                 }
3829                 # next HOSTEASY;
3830             } else {
3831                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3832             }
3833         }
3834         if (
3835             UNIVERSAL::can($ro_url,"text")
3836             and
3837             $ro_url->{FROM} eq "USER"
3838            ){
3839             ##address #17973: default URLs should not try to override
3840             ##user-defined URLs just because LWP is not available
3841             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3842             return $ret if $ret;
3843         }
3844         return if $CPAN::Signal;
3845     }
3846 }
3847
3848 # package CPAN::FTP;
3849 sub hosthard {
3850   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3851
3852   # Came back if Net::FTP couldn't establish connection (or
3853   # failed otherwise) Maybe they are behind a firewall, but they
3854   # gave us a socksified (or other) ftp program...
3855
3856   my($ro_url);
3857   my($devnull) = $CPAN::Config->{devnull} || "";
3858   # < /dev/null ";
3859   my($aslocal_dir) = File::Basename::dirname($aslocal);
3860   File::Path::mkpath($aslocal_dir);
3861   HOSTHARD: for $ro_url (@$host_seq) {
3862         $self->_set_attempt($stats,"hard",$ro_url);
3863         my $url = "$ro_url$file";
3864         my($proto,$host,$dir,$getfile);
3865
3866         # Courtesy Mark Conty mark_conty@cargill.com change from
3867         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3868         # to
3869         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3870           # proto not yet used
3871           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3872         } else {
3873           next HOSTHARD; # who said, we could ftp anything except ftp?
3874         }
3875         next HOSTHARD if $proto eq "file"; # file URLs would have had
3876                                            # success above. Likely a bogus URL
3877
3878         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3879
3880         # Try the most capable first and leave ncftp* for last as it only
3881         # does FTP.
3882       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3883           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3884           next unless defined $funkyftp;
3885           next if $funkyftp =~ /^\s*$/;
3886
3887           my($asl_ungz, $asl_gz);
3888           ($asl_ungz = $aslocal) =~ s/\.gz//;
3889           $asl_gz = "$asl_ungz.gz";
3890
3891           my($src_switch) = "";
3892           my($chdir) = "";
3893           my($stdout_redir) = " > $asl_ungz";
3894           if ($f eq "lynx"){
3895             $src_switch = " -source";
3896           } elsif ($f eq "ncftp"){
3897             $src_switch = " -c";
3898           } elsif ($f eq "wget"){
3899             $src_switch = " -O $asl_ungz";
3900             $stdout_redir = "";
3901           } elsif ($f eq 'curl'){
3902             $src_switch = ' -L -f -s -S --netrc-optional';
3903           }
3904
3905           if ($f eq "ncftpget"){
3906             $chdir = "cd $aslocal_dir && ";
3907             $stdout_redir = "";
3908           }
3909           $CPAN::Frontend->myprint(
3910                                    qq[
3911 Trying with "$funkyftp$src_switch" to get
3912     $url
3913 ]);
3914           my($system) =
3915               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
3916           $self->debug("system[$system]") if $CPAN::DEBUG;
3917           my($wstatus) = system($system);
3918           if ($f eq "lynx") {
3919               # lynx returns 0 when it fails somewhere
3920               if (-s $asl_ungz) {
3921                   my $content = do { local *FH;
3922                                      open FH, $asl_ungz or die;
3923                                      local $/;
3924                                      <FH> };
3925                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
3926                       $CPAN::Frontend->mywarn(qq{
3927 No success, the file that lynx has has downloaded looks like an error message:
3928 $content
3929 });
3930                       $CPAN::Frontend->mysleep(1);
3931                       next DLPRG;
3932                   }
3933               } else {
3934                   $CPAN::Frontend->myprint(qq{
3935 No success, the file that lynx has has downloaded is an empty file.
3936 });
3937                   next DLPRG;
3938               }
3939           }
3940           if ($wstatus == 0) {
3941             if (-s $aslocal) {
3942               # Looks good
3943             } elsif ($asl_ungz ne $aslocal) {
3944               # test gzip integrity
3945               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
3946                   # e.g. foo.tar is gzipped --> foo.tar.gz
3947                   rename $asl_ungz, $aslocal;
3948               } else {
3949                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
3950               }
3951             }
3952             $ThesiteURL = $ro_url;
3953             return $aslocal;
3954           } elsif ($url !~ /\.gz(?!\n)\Z/) {
3955             unlink $asl_ungz if
3956                 -f $asl_ungz && -s _ == 0;
3957             my $gz = "$aslocal.gz";
3958             my $gzurl = "$url.gz";
3959             $CPAN::Frontend->myprint(
3960                                      qq[
3961 Trying with "$funkyftp$src_switch" to get
3962   $url.gz
3963 ]);
3964             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
3965             $self->debug("system[$system]") if $CPAN::DEBUG;
3966             my($wstatus);
3967             if (($wstatus = system($system)) == 0
3968                 &&
3969                 -s $asl_gz
3970                ) {
3971               # test gzip integrity
3972                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
3973                 if ($ct && $ct->gtest) {
3974                     $ct->gunzip($aslocal);
3975                 } else {
3976                     # somebody uncompressed file for us?
3977                     rename $asl_ungz, $aslocal;
3978                 }
3979                 $ThesiteURL = $ro_url;
3980                 return $aslocal;
3981             } else {
3982               unlink $asl_gz if -f $asl_gz;
3983             }
3984           } else {
3985             my $estatus = $wstatus >> 8;
3986             my $size = -f $aslocal ?
3987                 ", left\n$aslocal with size ".-s _ :
3988                     "\nWarning: expected file [$aslocal] doesn't exist";
3989             $CPAN::Frontend->myprint(qq{
3990 System call "$system"
3991 returned status $estatus (wstat $wstatus)$size
3992 });
3993           }
3994           return if $CPAN::Signal;
3995         } # transfer programs
3996     } # host
3997 }
3998
3999 # package CPAN::FTP;
4000 sub hosthardest {
4001     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4002
4003     my($ro_url);
4004     my($aslocal_dir) = File::Basename::dirname($aslocal);
4005     File::Path::mkpath($aslocal_dir);
4006     my $ftpbin = $CPAN::Config->{ftp};
4007     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4008         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4009         return;
4010     }
4011     $CPAN::Frontend->mywarn(qq{
4012 As a last ressort we now switch to the external ftp command '$ftpbin'
4013 to get '$aslocal'.
4014
4015 Doing so often leads to problems that are hard to diagnose.
4016
4017 If you're victim of such problems, please consider unsetting the ftp
4018 config variable with
4019
4020     o conf ftp ""
4021     o conf commit
4022
4023 });
4024     $CPAN::Frontend->mysleep(2);
4025   HOSTHARDEST: for $ro_url (@$host_seq) {
4026         $self->_set_attempt($stats,"hardest",$ro_url);
4027         my $url = "$ro_url$file";
4028         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4029         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4030             next;
4031         }
4032         my($host,$dir,$getfile) = ($1,$2,$3);
4033         my $timestamp = 0;
4034         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4035            $ctime,$blksize,$blocks) = stat($aslocal);
4036         $timestamp = $mtime ||= 0;
4037         my($netrc) = CPAN::FTP::netrc->new;
4038         my($netrcfile) = $netrc->netrc;
4039         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4040         my $targetfile = File::Basename::basename($aslocal);
4041         my(@dialog);
4042         push(
4043              @dialog,
4044              "lcd $aslocal_dir",
4045              "cd /",
4046              map("cd $_", split /\//, $dir), # RFC 1738
4047              "bin",
4048              "get $getfile $targetfile",
4049              "quit"
4050             );
4051         if (! $netrcfile) {
4052             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4053         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4054             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4055                                 $netrc->hasdefault,
4056                                 $netrc->contains($host))) if $CPAN::DEBUG;
4057             if ($netrc->protected) {
4058                 my $dialog = join "", map { "    $_\n" } @dialog;
4059                 my $netrc_explain;
4060                 if ($netrc->contains($host)) {
4061                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4062                         "manages the login";
4063                 } else {
4064                     $netrc_explain = "Relying that your default .netrc entry ".
4065                         "manages the login";
4066                 }
4067                 $CPAN::Frontend->myprint(qq{
4068   Trying with external ftp to get
4069     $url
4070   $netrc_explain
4071   Going to send the dialog
4072 $dialog
4073 }
4074                      );
4075                 $self->talk_ftp("$ftpbin$verbose $host",
4076                                 @dialog);
4077                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4078                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4079                 $mtime ||= 0;
4080                 if ($mtime > $timestamp) {
4081                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4082                     $ThesiteURL = $ro_url;
4083                     return $aslocal;
4084                 } else {
4085                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4086                 }
4087                 return if $CPAN::Signal;
4088             } else {
4089                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4090                                         qq{correctly protected.\n});
4091             }
4092         } else {
4093             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4094   nor does it have a default entry\n");
4095         }
4096
4097         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4098         # then and login manually to host, using e-mail as
4099         # password.
4100         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4101         unshift(
4102                 @dialog,
4103                 "open $host",
4104                 "user anonymous $Config::Config{'cf_email'}"
4105                );
4106         my $dialog = join "", map { "    $_\n" } @dialog;
4107         $CPAN::Frontend->myprint(qq{
4108   Trying with external ftp to get
4109     $url
4110   Going to send the dialog
4111 $dialog
4112 }
4113                      );
4114         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4115         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4116          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4117         $mtime ||= 0;
4118         if ($mtime > $timestamp) {
4119             $CPAN::Frontend->myprint("GOT $aslocal\n");
4120             $ThesiteURL = $ro_url;
4121             return $aslocal;
4122         } else {
4123             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4124         }
4125         return if $CPAN::Signal;
4126         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4127         $CPAN::Frontend->mysleep(2);
4128     } # host
4129 }
4130
4131 # package CPAN::FTP;
4132 sub talk_ftp {
4133     my($self,$command,@dialog) = @_;
4134     my $fh = FileHandle->new;
4135     $fh->open("|$command") or die "Couldn't open ftp: $!";
4136     foreach (@dialog) { $fh->print("$_\n") }
4137     $fh->close;         # Wait for process to complete
4138     my $wstatus = $?;
4139     my $estatus = $wstatus >> 8;
4140     $CPAN::Frontend->myprint(qq{
4141 Subprocess "|$command"
4142   returned status $estatus (wstat $wstatus)
4143 }) if $wstatus;
4144 }
4145
4146 # find2perl needs modularization, too, all the following is stolen
4147 # from there
4148 # CPAN::FTP::ls
4149 sub ls {
4150     my($self,$name) = @_;
4151     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4152      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4153
4154     my($perms,%user,%group);
4155     my $pname = $name;
4156
4157     if ($blocks) {
4158         $blocks = int(($blocks + 1) / 2);
4159     }
4160     else {
4161         $blocks = int(($sizemm + 1023) / 1024);
4162     }
4163
4164     if    (-f _) { $perms = '-'; }
4165     elsif (-d _) { $perms = 'd'; }
4166     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4167     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4168     elsif (-p _) { $perms = 'p'; }
4169     elsif (-S _) { $perms = 's'; }
4170     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4171
4172     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4173     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4174     my $tmpmode = $mode;
4175     my $tmp = $rwx[$tmpmode & 7];
4176     $tmpmode >>= 3;
4177     $tmp = $rwx[$tmpmode & 7] . $tmp;
4178     $tmpmode >>= 3;
4179     $tmp = $rwx[$tmpmode & 7] . $tmp;
4180     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4181     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4182     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4183     $perms .= $tmp;
4184
4185     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4186     my $group = $group{$gid} || $gid;
4187
4188     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4189     my($timeyear);
4190     my($moname) = $moname[$mon];
4191     if (-M _ > 365.25 / 2) {
4192         $timeyear = $year + 1900;
4193     }
4194     else {
4195         $timeyear = sprintf("%02d:%02d", $hour, $min);
4196     }
4197
4198     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4199             $ino,
4200                  $blocks,
4201                       $perms,
4202                             $nlink,
4203                                 $user,
4204                                      $group,
4205                                           $sizemm,
4206                                               $moname,
4207                                                  $mday,
4208                                                      $timeyear,
4209                                                          $pname;
4210 }
4211
4212 package CPAN::FTP::netrc;
4213 use strict;
4214
4215 # package CPAN::FTP::netrc;
4216 sub new {
4217     my($class) = @_;
4218     my $home = CPAN::HandleConfig::home;
4219     my $file = File::Spec->catfile($home,".netrc");
4220
4221     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4222        $atime,$mtime,$ctime,$blksize,$blocks)
4223         = stat($file);
4224     $mode ||= 0;
4225     my $protected = 0;
4226
4227     my($fh,@machines,$hasdefault);
4228     $hasdefault = 0;
4229     $fh = FileHandle->new or die "Could not create a filehandle";
4230
4231     if($fh->open($file)){
4232         $protected = ($mode & 077) == 0;
4233         local($/) = "";
4234       NETRC: while (<$fh>) {
4235             my(@tokens) = split " ", $_;
4236           TOKEN: while (@tokens) {
4237                 my($t) = shift @tokens;
4238                 if ($t eq "default"){
4239                     $hasdefault++;
4240                     last NETRC;
4241                 }
4242                 last TOKEN if $t eq "macdef";
4243                 if ($t eq "machine") {
4244                     push @machines, shift @tokens;
4245                 }
4246             }
4247         }
4248     } else {
4249         $file = $hasdefault = $protected = "";
4250     }
4251
4252     bless {
4253            'mach' => [@machines],
4254            'netrc' => $file,
4255            'hasdefault' => $hasdefault,
4256            'protected' => $protected,
4257           }, $class;
4258 }
4259
4260 # CPAN::FTP::netrc::hasdefault;
4261 sub hasdefault { shift->{'hasdefault'} }
4262 sub netrc      { shift->{'netrc'}      }
4263 sub protected  { shift->{'protected'}  }
4264 sub contains {
4265     my($self,$mach) = @_;
4266     for ( @{$self->{'mach'}} ) {
4267         return 1 if $_ eq $mach;
4268     }
4269     return 0;
4270 }
4271
4272 package CPAN::Complete;
4273 use strict;
4274
4275 sub gnu_cpl {
4276     my($text, $line, $start, $end) = @_;
4277     my(@perlret) = cpl($text, $line, $start);
4278     # find longest common match. Can anybody show me how to peruse
4279     # T::R::Gnu to have this done automatically? Seems expensive.
4280     return () unless @perlret;
4281     my($newtext) = $text;
4282     for (my $i = length($text)+1;;$i++) {
4283         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4284         my $try = substr($perlret[0],0,$i);
4285         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4286         # warn "try[$try]tries[@tries]";
4287         if (@tries == @perlret) {
4288             $newtext = $try;
4289         } else {
4290             last;
4291         }
4292     }
4293     ($newtext,@perlret);
4294 }
4295
4296 #-> sub CPAN::Complete::cpl ;
4297 sub cpl {
4298     my($word,$line,$pos) = @_;
4299     $word ||= "";
4300     $line ||= "";
4301     $pos ||= 0;
4302     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4303     $line =~ s/^\s*//;
4304     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4305         $pos -= length($1);
4306     }
4307     my @return;
4308     if ($pos == 0) {
4309         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4310     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4311         @return = ();
4312     } elsif ($line =~ /^(a|ls)\s/) {
4313         @return = cplx('CPAN::Author',uc($word));
4314     } elsif ($line =~ /^b\s/) {
4315         CPAN::Shell->local_bundles;
4316         @return = cplx('CPAN::Bundle',$word);
4317     } elsif ($line =~ /^d\s/) {
4318         @return = cplx('CPAN::Distribution',$word);
4319     } elsif ($line =~ m/^(
4320                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4321                          )\s/x ) {
4322         if ($word =~ /^Bundle::/) {
4323             CPAN::Shell->local_bundles;
4324         }
4325         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4326     } elsif ($line =~ /^i\s/) {
4327         @return = cpl_any($word);
4328     } elsif ($line =~ /^reload\s/) {
4329         @return = cpl_reload($word,$line,$pos);
4330     } elsif ($line =~ /^o\s/) {
4331         @return = cpl_option($word,$line,$pos);
4332     } elsif ($line =~ m/^\S+\s/ ) {
4333         # fallback for future commands and what we have forgotten above
4334         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4335     } else {
4336         @return = ();
4337     }
4338     return @return;
4339 }
4340
4341 #-> sub CPAN::Complete::cplx ;
4342 sub cplx {
4343     my($class, $word) = @_;
4344     if (CPAN::_sqlite_running) {
4345         $CPAN::SQLite->search($class, "^\Q$word\E");
4346     }
4347     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4348 }
4349
4350 #-> sub CPAN::Complete::cpl_any ;
4351 sub cpl_any {
4352     my($word) = shift;
4353     return (
4354             cplx('CPAN::Author',$word),
4355             cplx('CPAN::Bundle',$word),
4356             cplx('CPAN::Distribution',$word),
4357             cplx('CPAN::Module',$word),
4358            );
4359 }
4360
4361 #-> sub CPAN::Complete::cpl_reload ;
4362 sub cpl_reload {
4363     my($word,$line,$pos) = @_;
4364     $word ||= "";
4365     my(@words) = split " ", $line;
4366     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4367     my(@ok) = qw(cpan index);
4368     return @ok if @words == 1;
4369     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4370 }
4371
4372 #-> sub CPAN::Complete::cpl_option ;
4373 sub cpl_option {
4374     my($word,$line,$pos) = @_;
4375     $word ||= "";
4376     my(@words) = split " ", $line;
4377     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4378     my(@ok) = qw(conf debug);
4379     return @ok if @words == 1;
4380     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4381     if (0) {
4382     } elsif ($words[1] eq 'index') {
4383         return ();
4384     } elsif ($words[1] eq 'conf') {
4385         return CPAN::HandleConfig::cpl(@_);
4386     } elsif ($words[1] eq 'debug') {
4387         return sort grep /^\Q$word\E/i,
4388             sort keys %CPAN::DEBUG, 'all';
4389     }
4390 }
4391
4392 package CPAN::Index;
4393 use strict;
4394
4395 #-> sub CPAN::Index::force_reload ;
4396 sub force_reload {
4397     my($class) = @_;
4398     $CPAN::Index::LAST_TIME = 0;
4399     $class->reload(1);
4400 }
4401
4402 #-> sub CPAN::Index::reload ;
4403 sub reload {
4404     my($self,$force) = @_;
4405     my $time = time;
4406
4407     # XXX check if a newer one is available. (We currently read it
4408     # from time to time)
4409     for ($CPAN::Config->{index_expire}) {
4410         $_ = 0.001 unless $_ && $_ > 0.001;
4411     }
4412     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4413         # debug here when CPAN doesn't seem to read the Metadata
4414         require Carp;
4415         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4416     }
4417     unless ($CPAN::META->{PROTOCOL}) {
4418         $self->read_metadata_cache;
4419         $CPAN::META->{PROTOCOL} ||= "1.0";
4420     }
4421     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4422         # warn "Setting last_time to 0";
4423         $LAST_TIME = 0; # No warning necessary
4424     }
4425     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4426         and ! $force){
4427         # called too often
4428         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4429     } elsif (0) {
4430         # IFF we are developing, it helps to wipe out the memory
4431         # between reloads, otherwise it is not what a user expects.
4432         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4433         $CPAN::META = CPAN->new;
4434     } else {
4435         my($debug,$t2);
4436         local $LAST_TIME = $time;
4437         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4438
4439         my $needshort = $^O eq "dos";
4440
4441         $self->rd_authindex($self
4442                           ->reload_x(
4443                                      "authors/01mailrc.txt.gz",
4444                                      $needshort ?
4445                                      File::Spec->catfile('authors', '01mailrc.gz') :
4446                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4447                                      $force));
4448         $t2 = time;
4449         $debug = "timing reading 01[".($t2 - $time)."]";
4450         $time = $t2;
4451         return if $CPAN::Signal; # this is sometimes lengthy
4452         $self->rd_modpacks($self
4453                          ->reload_x(
4454                                     "modules/02packages.details.txt.gz",
4455                                     $needshort ?
4456                                     File::Spec->catfile('modules', '02packag.gz') :
4457                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4458                                     $force));
4459         $t2 = time;
4460         $debug .= "02[".($t2 - $time)."]";
4461         $time = $t2;
4462         return if $CPAN::Signal; # this is sometimes lengthy
4463         $self->rd_modlist($self
4464                         ->reload_x(
4465                                    "modules/03modlist.data.gz",
4466                                    $needshort ?
4467                                    File::Spec->catfile('modules', '03mlist.gz') :
4468                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4469                                    $force));
4470         $self->write_metadata_cache;
4471         $t2 = time;
4472         $debug .= "03[".($t2 - $time)."]";
4473         $time = $t2;
4474         CPAN->debug($debug) if $CPAN::DEBUG;
4475     }
4476     if ($CPAN::Config->{build_dir_reuse}) {
4477         $self->reanimate_build_dir;
4478     }
4479     if (CPAN::_sqlite_running) {
4480         $CPAN::SQLite->reload(time => $time, force => $force)
4481             if not $LAST_TIME;
4482     }
4483     $LAST_TIME = $time;
4484     $CPAN::META->{PROTOCOL} = PROTOCOL;
4485 }
4486
4487 #-> sub CPAN::Index::reanimate_build_dir ;
4488 sub reanimate_build_dir {
4489     my($self) = @_;
4490     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4491         return;
4492     }
4493     return if $HAVE_REANIMATED++;
4494     my $d = $CPAN::Config->{build_dir};
4495     my $dh = DirHandle->new;
4496     opendir $dh, $d or return; # does not exist
4497     my $dirent;
4498     my $i = 0;
4499     my $painted = 0;
4500     my $restored = 0;
4501     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4502     my @candidates = map { $_->[0] }
4503         sort { $b->[1] <=> $a->[1] }
4504             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4505                 grep {/\.yml$/} readdir $dh;
4506   DISTRO: for $dirent (@candidates) {
4507         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4508         die $@ if $@;
4509         my $c = $y->[0];
4510         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4511             my $key = $c->{distribution}{ID};
4512             for my $k (keys %{$c->{distribution}}) {
4513                 if ($c->{distribution}{$k}
4514                     && ref $c->{distribution}{$k}
4515                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4516                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4517                 }
4518             }
4519
4520             #we tried to restore only if element already
4521             #exists; but then we do not work with metadata
4522             #turned off.
4523             my $do
4524                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4525                     = $c->{distribution};
4526             delete $do->{badtestcnt};
4527             # $DB::single = 1;
4528             if ($do->{make_test}
4529                 && $do->{build_dir}
4530                 && !$do->{make_test}->failed
4531                 && (
4532                     !$do->{install}
4533                     ||
4534                     $do->{install}->failed
4535                    )
4536                ) {
4537                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4538             }
4539             $restored++;
4540         }
4541         $i++;
4542         while (($painted/76) < ($i/@candidates)) {
4543             $CPAN::Frontend->myprint(".");
4544             $painted++;
4545         }
4546     }
4547     $CPAN::Frontend->myprint(sprintf(
4548                                      "DONE\nFound %s old builds, restored the state of %s\n",
4549                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4550                                      $restored || "none",
4551                                     ));
4552 }
4553
4554
4555 #-> sub CPAN::Index::reload_x ;
4556 sub reload_x {
4557     my($cl,$wanted,$localname,$force) = @_;
4558     $force |= 2; # means we're dealing with an index here
4559     CPAN::HandleConfig->load; # we should guarantee loading wherever
4560                               # we rely on Config XXX
4561     $localname ||= $wanted;
4562     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4563                                          $localname);
4564     if (
4565         -f $abs_wanted &&
4566         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4567         !($force & 1)
4568        ) {
4569         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4570         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4571                    qq{day$s. I\'ll use that.});
4572         return $abs_wanted;
4573     } else {
4574         $force |= 1; # means we're quite serious about it.
4575     }
4576     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4577 }
4578
4579 #-> sub CPAN::Index::rd_authindex ;
4580 sub rd_authindex {
4581     my($cl, $index_target) = @_;
4582     return unless defined $index_target;
4583     return if CPAN::_sqlite_running;
4584     my @lines;
4585     $CPAN::Frontend->myprint("Going to read $index_target\n");
4586     local(*FH);
4587     tie *FH, 'CPAN::Tarzip', $index_target;
4588     local($/) = "\n";
4589     local($_);
4590     push @lines, split /\012/ while <FH>;
4591     my $i = 0;
4592     my $painted = 0;
4593     foreach (@lines) {
4594         my($userid,$fullname,$email) =
4595             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4596         $fullname ||= $email;
4597         if ($userid && $fullname && $email){
4598             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4599             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4600         } else {
4601             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4602         }
4603         $i++;
4604         while (($painted/76) < ($i/@lines)) {
4605             $CPAN::Frontend->myprint(".");
4606             $painted++;
4607         }
4608         return if $CPAN::Signal;
4609     }
4610     $CPAN::Frontend->myprint("DONE\n");
4611 }
4612
4613 sub userid {
4614   my($self,$dist) = @_;
4615   $dist = $self->{'id'} unless defined $dist;
4616   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4617   $ret;
4618 }
4619
4620 #-> sub CPAN::Index::rd_modpacks ;
4621 sub rd_modpacks {
4622     my($self, $index_target) = @_;
4623     return unless defined $index_target;
4624     return if CPAN::_sqlite_running;
4625     $CPAN::Frontend->myprint("Going to read $index_target\n");
4626     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4627     local $_;
4628     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4629     my $slurp = "";
4630     my $chunk;
4631     while (my $bytes = $fh->READ(\$chunk,8192)) {
4632         $slurp.=$chunk;
4633     }
4634     my @lines = split /\012/, $slurp;
4635     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4636     undef $fh;
4637     # read header
4638     my($line_count,$last_updated);
4639     while (@lines) {
4640         my $shift = shift(@lines);
4641         last if $shift =~ /^\s*$/;
4642         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4643         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4644     }
4645     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4646     if (not defined $line_count) {
4647
4648         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4649 Please check the validity of the index file by comparing it to more
4650 than one CPAN mirror. I'll continue but problems seem likely to
4651 happen.\a
4652 });
4653
4654         $CPAN::Frontend->mysleep(5);
4655     } elsif ($line_count != scalar @lines) {
4656
4657         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4658 contains a Line-Count header of %d but I see %d lines there. Please
4659 check the validity of the index file by comparing it to more than one
4660 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4661 $index_target, $line_count, scalar(@lines));
4662
4663     }
4664     if (not defined $last_updated) {
4665
4666         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4667 Please check the validity of the index file by comparing it to more
4668 than one CPAN mirror. I'll continue but problems seem likely to
4669 happen.\a
4670 });
4671
4672         $CPAN::Frontend->mysleep(5);
4673     } else {
4674
4675         $CPAN::Frontend
4676             ->myprint(sprintf qq{  Database was generated on %s\n},
4677                       $last_updated);
4678         $DATE_OF_02 = $last_updated;
4679
4680         my $age = time;
4681         if ($CPAN::META->has_inst('HTTP::Date')) {
4682             require HTTP::Date;
4683             $age -= HTTP::Date::str2time($last_updated);
4684         } else {
4685             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4686             require Time::Local;
4687             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4688             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4689             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4690         }
4691         $age /= 3600*24;
4692         if ($age > 30) {
4693
4694             $CPAN::Frontend
4695                 ->mywarn(sprintf
4696                          qq{Warning: This index file is %d days old.
4697   Please check the host you chose as your CPAN mirror for staleness.
4698   I'll continue but problems seem likely to happen.\a\n},
4699                          $age);
4700
4701         } elsif ($age < -1) {
4702
4703             $CPAN::Frontend
4704                 ->mywarn(sprintf
4705                          qq{Warning: Your system date is %d days behind this index file!
4706   System time:          %s
4707   Timestamp index file: %s
4708   Please fix your system time, problems with the make command expected.\n},
4709                          -$age,
4710                          scalar gmtime,
4711                          $DATE_OF_02,
4712                         );
4713
4714         }
4715     }
4716
4717
4718     # A necessity since we have metadata_cache: delete what isn't
4719     # there anymore
4720     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4721     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4722     my(%exists);
4723     my $i = 0;
4724     my $painted = 0;
4725     foreach (@lines) {
4726         # before 1.56 we split into 3 and discarded the rest. From
4727         # 1.57 we assign remaining text to $comment thus allowing to
4728         # influence isa_perl
4729         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4730         my($bundle,$id,$userid);
4731
4732         if ($mod eq 'CPAN' &&
4733             ! (
4734                CPAN::Queue->exists('Bundle::CPAN') ||
4735                CPAN::Queue->exists('CPAN')
4736               )
4737            ) {
4738             local($^W)= 0;
4739             if ($version > $CPAN::VERSION){
4740                 $CPAN::Frontend->mywarn(qq{
4741   New CPAN.pm version (v$version) available.
4742   [Currently running version is v$CPAN::VERSION]
4743   You might want to try
4744     install CPAN
4745     reload cpan
4746   to both upgrade CPAN.pm and run the new version without leaving
4747   the current session.
4748
4749 }); #});
4750                 $CPAN::Frontend->mysleep(2);
4751                 $CPAN::Frontend->myprint(qq{\n});
4752             }
4753             last if $CPAN::Signal;
4754         } elsif ($mod =~ /^Bundle::(.*)/) {
4755             $bundle = $1;
4756         }
4757
4758         if ($bundle){
4759             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4760             # Let's make it a module too, because bundles have so much
4761             # in common with modules.
4762
4763             # Changed in 1.57_63: seems like memory bloat now without
4764             # any value, so commented out
4765
4766             # $CPAN::META->instance('CPAN::Module',$mod);
4767
4768         } else {
4769
4770             # instantiate a module object
4771             $id = $CPAN::META->instance('CPAN::Module',$mod);
4772
4773         }
4774
4775         # Although CPAN prohibits same name with different version the
4776         # indexer may have changed the version for the same distro
4777         # since the last time ("Force Reindexing" feature)
4778         if ($id->cpan_file ne $dist
4779             ||
4780             $id->cpan_version ne $version
4781            ){
4782             $userid = $id->userid || $self->userid($dist);
4783             $id->set(
4784                      'CPAN_USERID' => $userid,
4785                      'CPAN_VERSION' => $version,
4786                      'CPAN_FILE' => $dist,
4787                     );
4788         }
4789
4790         # instantiate a distribution object
4791         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4792           # we do not need CONTAINSMODS unless we do something with
4793           # this dist, so we better produce it on demand.
4794
4795           ## my $obj = $CPAN::META->instance(
4796           ##                              'CPAN::Distribution' => $dist
4797           ##                             );
4798           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4799         } else {
4800           $CPAN::META->instance(
4801                                 'CPAN::Distribution' => $dist
4802                                )->set(
4803                                       'CPAN_USERID' => $userid,
4804                                       'CPAN_COMMENT' => $comment,
4805                                      );
4806         }
4807         if ($secondtime) {
4808             for my $name ($mod,$dist) {
4809                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4810                 $exists{$name} = undef;
4811             }
4812         }
4813         $i++;
4814         while (($painted/76) < ($i/@lines)) {
4815             $CPAN::Frontend->myprint(".");
4816             $painted++;
4817         }
4818         return if $CPAN::Signal;
4819     }
4820     $CPAN::Frontend->myprint("DONE\n");
4821     if ($secondtime) {
4822         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4823             for my $o ($CPAN::META->all_objects($class)) {
4824                 next if exists $exists{$o->{ID}};
4825                 $CPAN::META->delete($class,$o->{ID});
4826                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4827                 #     if $CPAN::DEBUG;
4828             }
4829         }
4830     }
4831 }
4832
4833 #-> sub CPAN::Index::rd_modlist ;
4834 sub rd_modlist {
4835     my($cl,$index_target) = @_;
4836     return unless defined $index_target;
4837     return if CPAN::_sqlite_running;
4838     $CPAN::Frontend->myprint("Going to read $index_target\n");
4839     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4840     local $_;
4841     my $slurp = "";
4842     my $chunk;
4843     while (my $bytes = $fh->READ(\$chunk,8192)) {
4844         $slurp.=$chunk;
4845     }
4846     my @eval2 = split /\012/, $slurp;
4847
4848     while (@eval2) {
4849         my $shift = shift(@eval2);
4850         if ($shift =~ /^Date:\s+(.*)/){
4851             if ($DATE_OF_03 eq $1){
4852                 $CPAN::Frontend->myprint("Unchanged.\n");
4853                 return;
4854             }
4855             ($DATE_OF_03) = $1;
4856         }
4857         last if $shift =~ /^\s*$/;
4858     }
4859     push @eval2, q{CPAN::Modulelist->data;};
4860     local($^W) = 0;
4861     my($comp) = Safe->new("CPAN::Safe1");
4862     my($eval2) = join("\n", @eval2);
4863     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4864     my $ret = $comp->reval($eval2);
4865     Carp::confess($@) if $@;
4866     return if $CPAN::Signal;
4867     my $i = 0;
4868     my $until = keys(%$ret);
4869     my $painted = 0;
4870     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4871     for (keys %$ret) {
4872         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4873         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4874         $obj->set(%{$ret->{$_}});
4875         $i++;
4876         while (($painted/76) < ($i/$until)) {
4877             $CPAN::Frontend->myprint(".");
4878             $painted++;
4879         }
4880         return if $CPAN::Signal;
4881     }
4882     $CPAN::Frontend->myprint("DONE\n");
4883 }
4884
4885 #-> sub CPAN::Index::write_metadata_cache ;
4886 sub write_metadata_cache {
4887     my($self) = @_;
4888     return unless $CPAN::Config->{'cache_metadata'};
4889     return if CPAN::_sqlite_running;
4890     return unless $CPAN::META->has_usable("Storable");
4891     my $cache;
4892     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
4893                       CPAN::Distribution)) {
4894         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
4895     }
4896     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4897     $cache->{last_time} = $LAST_TIME;
4898     $cache->{DATE_OF_02} = $DATE_OF_02;
4899     $cache->{PROTOCOL} = PROTOCOL;
4900     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
4901     eval { Storable::nstore($cache, $metadata_file) };
4902     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4903 }
4904
4905 #-> sub CPAN::Index::read_metadata_cache ;
4906 sub read_metadata_cache {
4907     my($self) = @_;
4908     return unless $CPAN::Config->{'cache_metadata'};
4909     return if CPAN::_sqlite_running;
4910     return unless $CPAN::META->has_usable("Storable");
4911     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
4912     return unless -r $metadata_file and -f $metadata_file;
4913     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
4914     my $cache;
4915     eval { $cache = Storable::retrieve($metadata_file) };
4916     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
4917     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
4918         $LAST_TIME = 0;
4919         return;
4920     }
4921     if (exists $cache->{PROTOCOL}) {
4922         if (PROTOCOL > $cache->{PROTOCOL}) {
4923             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
4924                                             "with protocol v%s, requiring v%s\n",
4925                                             $cache->{PROTOCOL},
4926                                             PROTOCOL)
4927                                    );
4928             return;
4929         }
4930     } else {
4931         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
4932                                 "with protocol v1.0\n");
4933         return;
4934     }
4935     my $clcnt = 0;
4936     my $idcnt = 0;
4937     while(my($class,$v) = each %$cache) {
4938         next unless $class =~ /^CPAN::/;
4939         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
4940         while (my($id,$ro) = each %$v) {
4941             $CPAN::META->{readwrite}{$class}{$id} ||=
4942                 $class->new(ID=>$id, RO=>$ro);
4943             $idcnt++;
4944         }
4945         $clcnt++;
4946     }
4947     unless ($clcnt) { # sanity check
4948         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
4949         return;
4950     }
4951     if ($idcnt < 1000) {
4952         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
4953                                  "in $metadata_file\n");
4954         return;
4955     }
4956     $CPAN::META->{PROTOCOL} ||=
4957         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
4958                             # does initialize to some protocol
4959     $LAST_TIME = $cache->{last_time};
4960     $DATE_OF_02 = $cache->{DATE_OF_02};
4961     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
4962         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
4963     return;
4964 }
4965
4966 package CPAN::InfoObj;
4967 use strict;
4968
4969 sub ro {
4970     my $self = shift;
4971     exists $self->{RO} and return $self->{RO};
4972 }
4973
4974 #-> sub CPAN::InfoObj::cpan_userid
4975 sub cpan_userid {
4976     my $self = shift;
4977     my $ro = $self->ro;
4978     if ($ro) {
4979         return $ro->{CPAN_USERID} || "N/A";
4980     } else {
4981         $self->debug("ID[$self->{ID}]");
4982         # N/A for bundles found locally
4983         return "N/A";
4984     }
4985 }
4986
4987 sub id { shift->{ID}; }
4988
4989 #-> sub CPAN::InfoObj::new ;
4990 sub new {
4991     my $this = bless {}, shift;
4992     %$this = @_;
4993     $this
4994 }
4995
4996 # The set method may only be used by code that reads index data or
4997 # otherwise "objective" data from the outside world. All session
4998 # related material may do anything else with instance variables but
4999 # must not touch the hash under the RO attribute. The reason is that
5000 # the RO hash gets written to Metadata file and is thus persistent.
5001
5002 #-> sub CPAN::InfoObj::safe_chdir ;
5003 sub safe_chdir {
5004   my($self,$todir) = @_;
5005   # we die if we cannot chdir and we are debuggable
5006   Carp::confess("safe_chdir called without todir argument")
5007         unless defined $todir and length $todir;
5008   if (chdir $todir) {
5009     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5010         if $CPAN::DEBUG;
5011   } else {
5012     if (-e $todir) {
5013         unless (-x $todir) {
5014             unless (chmod 0755, $todir) {
5015                 my $cwd = CPAN::anycwd();
5016                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5017                                         "permission to change the permission; cannot ".
5018                                         "chdir to '$todir'\n");
5019                 $CPAN::Frontend->mysleep(5);
5020                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5021                                        qq{to todir[$todir]: $!});
5022             }
5023         }
5024     } else {
5025         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5026     }
5027     if (chdir $todir) {
5028       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5029           if $CPAN::DEBUG;
5030     } else {
5031       my $cwd = CPAN::anycwd();
5032       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5033                              qq{to todir[$todir] (a chmod has been issued): $!});
5034     }
5035   }
5036 }
5037
5038 #-> sub CPAN::InfoObj::set ;
5039 sub set {
5040     my($self,%att) = @_;
5041     my $class = ref $self;
5042
5043     # This must be ||=, not ||, because only if we write an empty
5044     # reference, only then the set method will write into the readonly
5045     # area. But for Distributions that spring into existence, maybe
5046     # because of a typo, we do not like it that they are written into
5047     # the readonly area and made permanent (at least for a while) and
5048     # that is why we do not "allow" other places to call ->set.
5049     unless ($self->id) {
5050         CPAN->debug("Bug? Empty ID, rejecting");
5051         return;
5052     }
5053     my $ro = $self->{RO} =
5054         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5055
5056     while (my($k,$v) = each %att) {
5057         $ro->{$k} = $v;
5058     }
5059 }
5060
5061 #-> sub CPAN::InfoObj::as_glimpse ;
5062 sub as_glimpse {
5063     my($self) = @_;
5064     my(@m);
5065     my $class = ref($self);
5066     $class =~ s/^CPAN:://;
5067     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5068     push @m, sprintf "%-15s %s\n", $class, $id;
5069     join "", @m;
5070 }
5071
5072 #-> sub CPAN::InfoObj::as_string ;
5073 sub as_string {
5074     my($self) = @_;
5075     my(@m);
5076     my $class = ref($self);
5077     $class =~ s/^CPAN:://;
5078     push @m, $class, " id = $self->{ID}\n";
5079     my $ro;
5080     unless ($ro = $self->ro) {
5081         if (substr($self->{ID},-1,1) eq ".") { # directory
5082             $ro = +{};
5083         } else {
5084             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5085         }
5086     }
5087     for (sort keys %$ro) {
5088         # next if m/^(ID|RO)$/;
5089         my $extra = "";
5090         if ($_ eq "CPAN_USERID") {
5091             $extra .= " (";
5092             $extra .= $self->fullname;
5093             my $email; # old perls!
5094             if ($email = $CPAN::META->instance("CPAN::Author",
5095                                                $self->cpan_userid
5096                                               )->email) {
5097                 $extra .= " <$email>";
5098             } else {
5099                 $extra .= " <no email>";
5100             }
5101             $extra .= ")";
5102         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5103             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5104             next;
5105         }
5106         next unless defined $ro->{$_};
5107         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5108     }
5109   KEY: for (sort keys %$self) {
5110         next if m/^(ID|RO)$/;
5111         unless (defined $self->{$_}) {
5112             delete $self->{$_};
5113             next KEY;
5114         }
5115         if (ref($self->{$_}) eq "ARRAY") {
5116           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5117         } elsif (ref($self->{$_}) eq "HASH") {
5118             my $value;
5119             if (/^CONTAINSMODS$/) {
5120                 $value = join(" ",sort keys %{$self->{$_}});
5121             } elsif (/^prereq_pm$/) {
5122                 my @value;
5123                 my $v = $self->{$_};
5124                 for my $x (sort keys %$v) {
5125                     my @svalue;
5126                     for my $y (sort keys %{$v->{$x}}) {
5127                         push @svalue, "$y=>$v->{$x}{$y}";
5128                     }
5129                     push @value, "$x\:" . join ",", @svalue if @svalue;
5130                 }
5131                 $value = join ";", @value;
5132             } else {
5133                 $value = $self->{$_};
5134             }
5135           push @m, sprintf(
5136                            "    %-12s %s\n",
5137                            $_,
5138                            $value,
5139                           );
5140         } else {
5141           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5142         }
5143     }
5144     join "", @m, "\n";
5145 }
5146
5147 #-> sub CPAN::InfoObj::fullname ;
5148 sub fullname {
5149     my($self) = @_;
5150     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5151 }
5152
5153 #-> sub CPAN::InfoObj::dump ;
5154 sub dump {
5155   my($self, $what) = @_;
5156   unless ($CPAN::META->has_inst("Data::Dumper")) {
5157       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5158   }
5159   local $Data::Dumper::Sortkeys;
5160   $Data::Dumper::Sortkeys = 1;
5161   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5162   if (length $out > 100000) {
5163       my $fh_pager = FileHandle->new;
5164       local($SIG{PIPE}) = "IGNORE";
5165       my $pager = $CPAN::Config->{'pager'} || "cat";
5166       $fh_pager->open("|$pager")
5167           or die "Could not open pager $pager\: $!";
5168       $fh_pager->print($out);
5169       close $fh_pager;
5170   } else {
5171       $CPAN::Frontend->myprint($out);
5172   }
5173 }
5174
5175 package CPAN::Author;
5176 use strict;
5177
5178 #-> sub CPAN::Author::force
5179 sub force {
5180     my $self = shift;
5181     $self->{force}++;
5182 }
5183
5184 #-> sub CPAN::Author::force
5185 sub unforce {
5186     my $self = shift;
5187     delete $self->{force};
5188 }
5189
5190 #-> sub CPAN::Author::id
5191 sub id {
5192     my $self = shift;
5193     my $id = $self->{ID};
5194     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5195     $id;
5196 }
5197
5198 #-> sub CPAN::Author::as_glimpse ;
5199 sub as_glimpse {
5200     my($self) = @_;
5201     my(@m);
5202     my $class = ref($self);
5203     $class =~ s/^CPAN:://;
5204     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5205                      $class,
5206                      $self->{ID},
5207                      $self->fullname,
5208                      $self->email);
5209     join "", @m;
5210 }
5211
5212 #-> sub CPAN::Author::fullname ;
5213 sub fullname {
5214     shift->ro->{FULLNAME};
5215 }
5216 *name = \&fullname;
5217
5218 #-> sub CPAN::Author::email ;
5219 sub email    { shift->ro->{EMAIL}; }
5220
5221 #-> sub CPAN::Author::ls ;
5222 sub ls {
5223     my $self = shift;
5224     my $glob = shift || "";
5225     my $silent = shift || 0;
5226     my $id = $self->id;
5227
5228     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5229     my(@csf); # chksumfile
5230     @csf = $self->id =~ /(.)(.)(.*)/;
5231     $csf[1] = join "", @csf[0,1];
5232     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5233     my(@dl);
5234     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5235     unless (grep {$_->[2] eq $csf[1]} @dl) {
5236         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5237         return;
5238     }
5239     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5240     unless (grep {$_->[2] eq $csf[2]} @dl) {
5241         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5242         return;
5243     }
5244     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5245     if ($glob) {
5246         if ($CPAN::META->has_inst("Text::Glob")) {
5247             my $rglob = Text::Glob::glob_to_regex($glob);
5248             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5249         } else {
5250             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5251         }
5252     }
5253     $CPAN::Frontend->myprint(join "", map {
5254         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5255     } sort { $a->[2] cmp $b->[2] } @dl);
5256     @dl;
5257 }
5258
5259 # returns an array of arrays, the latter contain (size,mtime,filename)
5260 #-> sub CPAN::Author::dir_listing ;
5261 sub dir_listing {
5262     my $self = shift;
5263     my $chksumfile = shift;
5264     my $recursive = shift;
5265     my $may_ftp = shift;
5266
5267     my $lc_want =
5268         File::Spec->catfile($CPAN::Config->{keep_source_where},
5269                             "authors", "id", @$chksumfile);
5270
5271     my $fh;
5272
5273     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5274     # hazard.  (Without GPG installed they are not that much better,
5275     # though.)
5276     $fh = FileHandle->new;
5277     if (open($fh, $lc_want)) {
5278         my $line = <$fh>; close $fh;
5279         unlink($lc_want) unless $line =~ /PGP/;
5280     }
5281
5282     local($") = "/";
5283     # connect "force" argument with "index_expire".
5284     my $force = $self->{force};
5285     if (my @stat = stat $lc_want) {
5286         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5287     }
5288     my $lc_file;
5289     if ($may_ftp) {
5290         $lc_file = CPAN::FTP->localize(
5291                                        "authors/id/@$chksumfile",
5292                                        $lc_want,
5293                                        $force,
5294                                       );
5295         unless ($lc_file) {
5296             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5297             $chksumfile->[-1] .= ".gz";
5298             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5299                                            "$lc_want.gz",1);
5300             if ($lc_file) {
5301                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5302                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5303             } else {
5304                 return;
5305             }
5306         }
5307     } else {
5308         $lc_file = $lc_want;
5309         # we *could* second-guess and if the user has a file: URL,
5310         # then we could look there. But on the other hand, if they do
5311         # have a file: URL, wy did they choose to set
5312         # $CPAN::Config->{show_upload_date} to false?
5313     }
5314
5315     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5316     $fh = FileHandle->new;
5317     my($cksum);
5318     if (open $fh, $lc_file){
5319         local($/);
5320         my $eval = <$fh>;
5321         $eval =~ s/\015?\012/\n/g;
5322         close $fh;
5323         my($comp) = Safe->new();
5324         $cksum = $comp->reval($eval);
5325         if ($@) {
5326             rename $lc_file, "$lc_file.bad";
5327             Carp::confess($@) if $@;
5328         }
5329     } elsif ($may_ftp) {
5330         Carp::carp "Could not open '$lc_file' for reading.";
5331     } else {
5332         # Maybe should warn: "You may want to set show_upload_date to a true value"
5333         return;
5334     }
5335     my(@result,$f);
5336     for $f (sort keys %$cksum) {
5337         if (exists $cksum->{$f}{isdir}) {
5338             if ($recursive) {
5339                 my(@dir) = @$chksumfile;
5340                 pop @dir;
5341                 push @dir, $f, "CHECKSUMS";
5342                 push @result, map {
5343                     [$_->[0], $_->[1], "$f/$_->[2]"]
5344                 } $self->dir_listing(\@dir,1,$may_ftp);
5345             } else {
5346                 push @result, [ 0, "-", $f ];
5347             }
5348         } else {
5349             push @result, [
5350                            ($cksum->{$f}{"size"}||0),
5351                            $cksum->{$f}{"mtime"}||"---",
5352                            $f
5353                           ];
5354         }
5355     }
5356     @result;
5357 }
5358
5359 package CPAN::Distribution;
5360 use strict;
5361
5362 # Accessors
5363 sub cpan_comment {
5364     my $self = shift;
5365     my $ro = $self->ro or return;
5366     $ro->{CPAN_COMMENT}
5367 }
5368
5369 # CPAN::Distribution::undelay
5370 sub undelay {
5371     my $self = shift;
5372     delete $self->{later};
5373 }
5374
5375 # add the A/AN/ stuff
5376 # CPAN::Distribution::normalize
5377 sub normalize {
5378     my($self,$s) = @_;
5379     $s = $self->id unless defined $s;
5380     if (substr($s,-1,1) eq ".") {
5381         # using a global because we are sometimes called as static method
5382         if (!$CPAN::META->{LOCK}
5383             && !$CPAN::Have_warned->{"$s is unlocked"}++
5384            ) {
5385             $CPAN::Frontend->mywarn("You are visiting the local directory
5386   '$s'
5387   without lock, take care that concurrent processes do not do likewise.\n");
5388             $CPAN::Frontend->mysleep(1);
5389         }
5390         if ($s eq ".") {
5391             $s = "$CPAN::iCwd/.";
5392         } elsif (File::Spec->file_name_is_absolute($s)) {
5393         } elsif (File::Spec->can("rel2abs")) {
5394             $s = File::Spec->rel2abs($s);
5395         } else {
5396             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5397         }
5398         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5399         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5400             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5401                 $_->{build_dir} = $s;
5402                 $_->{archived} = "local_directory";
5403                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5404             }
5405         }
5406     } elsif (
5407         $s =~ tr|/|| == 1
5408         or
5409         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5410        ) {
5411         return $s if $s =~ m:^N/A|^Contact Author: ;
5412         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5413             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5414         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5415     }
5416     $s;
5417 }
5418
5419 #-> sub CPAN::Distribution::author ;
5420 sub author {
5421     my($self) = @_;
5422     my($authorid);
5423     if (substr($self->id,-1,1) eq ".") {
5424         $authorid = "LOCAL";
5425     } else {
5426         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5427     }
5428     CPAN::Shell->expand("Author",$authorid);
5429 }
5430
5431 # tries to get the yaml from CPAN instead of the distro itself:
5432 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5433 sub fast_yaml {
5434     my($self) = @_;
5435     my $meta = $self->pretty_id;
5436     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5437     my(@ls) = CPAN::Shell->globls($meta);
5438     my $norm = $self->normalize($meta);
5439
5440     my($local_file);
5441     my($local_wanted) =
5442         File::Spec->catfile(
5443                             $CPAN::Config->{keep_source_where},
5444                             "authors",
5445                             "id",
5446                             split(/\//,$norm)
5447                            );
5448     $self->debug("Doing localize") if $CPAN::DEBUG;
5449     unless ($local_file =
5450             CPAN::FTP->localize("authors/id/$norm",
5451                                 $local_wanted)) {
5452         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5453     }
5454     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5455 }
5456
5457 #-> sub CPAN::Distribution::cpan_userid
5458 sub cpan_userid {
5459     my $self = shift;
5460     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5461         return $1;
5462     }
5463     return $self->SUPER::cpan_userid;
5464 }
5465
5466 #-> sub CPAN::Distribution::pretty_id
5467 sub pretty_id {
5468     my $self = shift;
5469     my $id = $self->id;
5470     return $id unless $id =~ m|^./../|;
5471     substr($id,5);
5472 }
5473
5474 # mark as dirty/clean for the sake of recursion detection. $color=1
5475 # means "in use", $color=0 means "not in use anymore". $color=2 means
5476 # we have determined prereqs now and thus insist on passing this
5477 # through (at least) once again.
5478
5479 #-> sub CPAN::Distribution::color_cmd_tmps ;
5480 sub color_cmd_tmps {
5481     my($self) = shift;
5482     my($depth) = shift || 0;
5483     my($color) = shift || 0;
5484     my($ancestors) = shift || [];
5485     # a distribution needs to recurse into its prereq_pms
5486
5487     return if exists $self->{incommandcolor}
5488         && $color==1
5489         && $self->{incommandcolor}==$color;
5490     if ($depth>=$CPAN::MAX_RECURSION){
5491         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
5492     }
5493     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5494     my $prereq_pm = $self->prereq_pm;
5495     if (defined $prereq_pm) {
5496       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5497                            keys %{$prereq_pm->{build_requires}||{}}) {
5498             next PREREQ if $pre eq "perl";
5499             my $premo;
5500             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5501                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5502                 $CPAN::Frontend->mysleep(2);
5503                 next PREREQ;
5504             }
5505             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5506         }
5507     }
5508     if ($color==0) {
5509         delete $self->{sponsored_mods};
5510
5511         # as we are at the end of a command, we'll give up this
5512         # reminder of a broken test. Other commands may test this guy
5513         # again. Maybe 'badtestcnt' should be renamed to
5514         # 'make_test_failed_within_command'?
5515         delete $self->{badtestcnt};
5516     }
5517     $self->{incommandcolor} = $color;
5518 }
5519
5520 #-> sub CPAN::Distribution::as_string ;
5521 sub as_string {
5522   my $self = shift;
5523   $self->containsmods;
5524   $self->upload_date;
5525   $self->SUPER::as_string(@_);
5526 }
5527
5528 #-> sub CPAN::Distribution::containsmods ;
5529 sub containsmods {
5530   my $self = shift;
5531   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5532   my $dist_id = $self->{ID};
5533   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5534     my $mod_file = $mod->cpan_file or next;
5535     my $mod_id = $mod->{ID} or next;
5536     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5537     # sleep 1;
5538     if ($CPAN::Signal) {
5539         delete $self->{CONTAINSMODS};
5540         return;
5541     }
5542     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5543   }
5544   keys %{$self->{CONTAINSMODS}||{}};
5545 }
5546
5547 #-> sub CPAN::Distribution::upload_date ;
5548 sub upload_date {
5549   my $self = shift;
5550   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5551   my(@local_wanted) = split(/\//,$self->id);
5552   my $filename = pop @local_wanted;
5553   push @local_wanted, "CHECKSUMS";
5554   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5555   return unless $author;
5556   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5557   return unless @dl;
5558   my($dirent) = grep { $_->[2] eq $filename } @dl;
5559   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5560   return unless $dirent->[1];
5561   return $self->{UPLOAD_DATE} = $dirent->[1];
5562 }
5563
5564 #-> sub CPAN::Distribution::uptodate ;
5565 sub uptodate {
5566     my($self) = @_;
5567     my $c;
5568     foreach $c ($self->containsmods) {
5569         my $obj = CPAN::Shell->expandany($c);
5570         unless ($obj->uptodate){
5571             my $id = $self->pretty_id;
5572             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5573             return 0;
5574         }
5575     }
5576     return 1;
5577 }
5578
5579 #-> sub CPAN::Distribution::called_for ;
5580 sub called_for {
5581     my($self,$id) = @_;
5582     $self->{CALLED_FOR} = $id if defined $id;
5583     return $self->{CALLED_FOR};
5584 }
5585
5586 #-> sub CPAN::Distribution::get ;
5587 sub get {
5588     my($self) = @_;
5589     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5590     if (my $goto = $self->prefs->{goto}) {
5591         $CPAN::Frontend->mywarn
5592             (sprintf(
5593                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5594                      $goto,
5595                      $self->{prefs_file},
5596                      $self->{prefs_file_doc},
5597                     ));
5598         return $self->goto($goto);
5599     }
5600     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5601                            ? $ENV{PERL5LIB}
5602                            : ($ENV{PERLLIB} || "");
5603
5604     $CPAN::META->set_perl5lib;
5605     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5606
5607   EXCUSE: {
5608         my @e;
5609         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5610         if ($self->prefs->{disabled}) {
5611             my $why = sprintf(
5612                               "Disabled via prefs file '%s' doc %d",
5613                               $self->{prefs_file},
5614                               $self->{prefs_file_doc},
5615                              );
5616             push @e, $why;
5617             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5618             # note: not intended to be persistent but at least visible
5619             # during this session
5620         } else {
5621             if (exists $self->{build_dir}) {
5622                 # this deserves print, not warn:
5623                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5624                                          "$self->{build_dir}\n"
5625                                         );
5626                 return;
5627             }
5628
5629             # although we talk about 'force' we shall not test on
5630             # force directly. New model of force tries to refrain from
5631             # direct checking of force.
5632             exists $self->{unwrapped} and (
5633                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5634                                            $self->{unwrapped}->failed :
5635                                            $self->{unwrapped} =~ /^NO/
5636                                           )
5637                 and push @e, "Unwrapping had some problem, won't try again without force";
5638         }
5639
5640         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5641     }
5642     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5643
5644     #
5645     # Get the file on local disk
5646     #
5647
5648     my($local_file);
5649     my($local_wanted) =
5650         File::Spec->catfile(
5651                             $CPAN::Config->{keep_source_where},
5652                             "authors",
5653                             "id",
5654                             split(/\//,$self->id)
5655                            );
5656
5657     $self->debug("Doing localize") if $CPAN::DEBUG;
5658     unless ($local_file =
5659             CPAN::FTP->localize("authors/id/$self->{ID}",
5660                                 $local_wanted)) {
5661         my $note = "";
5662         if ($CPAN::Index::DATE_OF_02) {
5663             $note = "Note: Current database in memory was generated ".
5664                 "on $CPAN::Index::DATE_OF_02\n";
5665         }
5666         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5667     }
5668
5669     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5670     $self->{localfile} = $local_file;
5671     return if $CPAN::Signal;
5672
5673     #
5674     # Check integrity
5675     #
5676     if ($CPAN::META->has_inst("Digest::SHA")) {
5677         $self->debug("Digest::SHA is installed, verifying");
5678         $self->verifyCHECKSUM;
5679     } else {
5680         $self->debug("Digest::SHA is NOT installed");
5681     }
5682     return if $CPAN::Signal;
5683
5684     #
5685     # Create a clean room and go there
5686     #
5687     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5688     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5689     $self->safe_chdir($builddir);
5690     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5691     File::Path::rmtree("tmp-$$");
5692     unless (mkdir "tmp-$$", 0755) {
5693         $CPAN::Frontend->unrecoverable_error(<<EOF);
5694 Couldn't mkdir '$builddir/tmp-$$': $!
5695
5696 Cannot continue: Please find the reason why I cannot make the
5697 directory
5698 $builddir/tmp-$$
5699 and fix the problem, then retry.
5700
5701 EOF
5702     }
5703     if ($CPAN::Signal){
5704         $self->safe_chdir($sub_wd);
5705         return;
5706     }
5707     $self->safe_chdir("tmp-$$");
5708
5709     #
5710     # Unpack the goods
5711     #
5712     my $ct = eval{CPAN::Tarzip->new($local_file)};
5713     unless ($ct) {
5714         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5715         delete $self->{build_dir};
5716         return;
5717     }
5718     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5719         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5720         $self->untar_me($ct);
5721     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5722         $self->unzip_me($ct);
5723     } else {
5724         $self->{was_uncompressed}++ unless $ct->gtest();
5725         $local_file = $self->handle_singlefile($local_file);
5726     }
5727
5728     # we are still in the tmp directory!
5729     # Let's check if the package has its own directory.
5730     my $dh = DirHandle->new(File::Spec->curdir)
5731         or Carp::croak("Couldn't opendir .: $!");
5732     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5733     $dh->close;
5734     my ($packagedir);
5735     # XXX here we want in each branch File::Temp to protect all build_dir directories
5736     if (CPAN->has_inst("File::Temp")) {
5737         my $tdir_base;
5738         my $from_dir;
5739         my @dirents;
5740         if (@readdir == 1 && -d $readdir[0]) {
5741             $tdir_base = $readdir[0];
5742             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5743             my $dh2 = DirHandle->new($from_dir)
5744                 or Carp::croak("Couldn't opendir $from_dir: $!");
5745             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5746         } else {
5747             my $userid = $self->cpan_userid;
5748             CPAN->debug("userid[$userid]");
5749             if (!$userid or $userid eq "N/A") {
5750                 $userid = "anon";
5751             }
5752             $tdir_base = $userid;
5753             $from_dir = File::Spec->curdir;
5754             @dirents = @readdir;
5755         }
5756         $packagedir = File::Temp::tempdir(
5757                                           "$tdir_base-XXXXXX",
5758                                           DIR => $builddir,
5759                                           CLEANUP => 0,
5760                                          );
5761         my $f;
5762         for $f (@dirents) { # is already without "." and ".."
5763             my $from = File::Spec->catdir($from_dir,$f);
5764             my $to = File::Spec->catdir($packagedir,$f);
5765             unless (File::Copy::move($from,$to)) {
5766                 my $err = $!;
5767                 $from = File::Spec->rel2abs($from);
5768                 Carp::confess("Couldn't move $from to $to: $err");
5769             }
5770         }
5771     } else { # older code below, still better than nothing when there is no File::Temp
5772         my($distdir);
5773         if (@readdir == 1 && -d $readdir[0]) {
5774             $distdir = $readdir[0];
5775             $packagedir = File::Spec->catdir($builddir,$distdir);
5776             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5777                 if $CPAN::DEBUG;
5778             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5779                                                         "$packagedir\n");
5780             File::Path::rmtree($packagedir);
5781             unless (File::Copy::move($distdir,$packagedir)) {
5782                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5783 Couldn't move '$distdir' to '$packagedir': $!
5784
5785 Cannot continue: Please find the reason why I cannot move
5786 $builddir/tmp-$$/$distdir
5787 to
5788 $packagedir
5789 and fix the problem, then retry
5790
5791 EOF
5792             }
5793             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5794                                  $distdir,
5795                                  $packagedir,
5796                                  -e $packagedir,
5797                                  -d $packagedir,
5798                                 )) if $CPAN::DEBUG;
5799         } else {
5800             my $userid = $self->cpan_userid;
5801             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5802             if (!$userid or $userid eq "N/A") {
5803                 $userid = "anon";
5804             }
5805             my $pragmatic_dir = $userid . '000';
5806             $pragmatic_dir =~ s/\W_//g;
5807             $pragmatic_dir++ while -d "../$pragmatic_dir";
5808             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5809             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5810             File::Path::mkpath($packagedir);
5811             my($f);
5812             for $f (@readdir) { # is already without "." and ".."
5813                 my $to = File::Spec->catdir($packagedir,$f);
5814                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5815             }
5816         }
5817     }
5818     if ($CPAN::Signal){
5819         $self->safe_chdir($sub_wd);
5820         return;
5821     }
5822
5823     $self->{build_dir} = $packagedir;
5824     $self->safe_chdir($builddir);
5825     File::Path::rmtree("tmp-$$");
5826
5827     $self->safe_chdir($packagedir);
5828     $self->_signature_business();
5829     $self->safe_chdir($builddir);
5830     return if $CPAN::Signal;
5831
5832
5833     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5834     my($mpl_exists) = -f $mpl;
5835     unless ($mpl_exists) {
5836         # NFS has been reported to have racing problems after the
5837         # renaming of a directory in some environments.
5838         # This trick helps.
5839         $CPAN::Frontend->mysleep(1);
5840         my $mpldh = DirHandle->new($packagedir)
5841             or Carp::croak("Couldn't opendir $packagedir: $!");
5842         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5843         $mpldh->close;
5844     }
5845     my $prefer_installer = "eumm"; # eumm|mb
5846     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5847         if ($mpl_exists) { # they *can* choose
5848             if ($CPAN::META->has_inst("Module::Build")) {
5849                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5850                                                                      q{prefer_installer});
5851             }
5852         } else {
5853             $prefer_installer = "mb";
5854         }
5855     }
5856     return unless $self->patch;
5857     if (lc($prefer_installer) eq "mb") {
5858         $self->{modulebuild} = 1;
5859     } elsif ($self->{archived} eq "patch") {
5860         # not an edge case, nothing to install for sure
5861         my $why = "A patch file cannot be installed";
5862         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
5863         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
5864     } elsif (! $mpl_exists) {
5865         $self->_edge_cases($mpl,$packagedir,$local_file);
5866     }
5867     if ($self->{build_dir}
5868         &&
5869         $CPAN::Config->{build_dir_reuse}
5870        ) {
5871         $self->store_persistent_state;
5872     }
5873
5874     return $self;
5875 }
5876
5877 #-> CPAN::Distribution::store_persistent_state
5878 sub store_persistent_state {
5879     my($self) = @_;
5880     my $dir = $self->{build_dir};
5881     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5882             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5883         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5884                                 "will not store persistent state\n");
5885         return;
5886     }
5887     my $file = sprintf "%s.yml", $dir;
5888     my $yaml_module = CPAN::_yaml_module;
5889     if ($CPAN::META->has_inst($yaml_module)) {
5890         CPAN->_yaml_dumpfile(
5891                              $file,
5892                              {
5893                               time => time,
5894                               perl => CPAN::_perl_fingerprint,
5895                               distribution => $self,
5896                              }
5897                             );
5898     } else {
5899         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
5900                                 "will not store persistent state\n");
5901     }
5902 }
5903
5904 #-> CPAN::Distribution::patch
5905 sub try_download {
5906     my($self,$patch) = @_;
5907     my $norm = $self->normalize($patch);
5908     my($local_wanted) =
5909         File::Spec->catfile(
5910                             $CPAN::Config->{keep_source_where},
5911                             "authors",
5912                             "id",
5913                             split(/\//,$norm),
5914                             );
5915     $self->debug("Doing localize") if $CPAN::DEBUG;
5916     return CPAN::FTP->localize("authors/id/$norm",
5917                                $local_wanted);
5918 }
5919
5920 #-> CPAN::Distribution::patch
5921 sub patch {
5922     my($self) = @_;
5923     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
5924     my $patches = $self->prefs->{patches};
5925     $patches ||= "";
5926     $self->debug("patches[$patches]") if $CPAN::DEBUG;
5927     if ($patches) {
5928         return unless @$patches;
5929         $self->safe_chdir($self->{build_dir});
5930         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
5931         my $patchbin = $CPAN::Config->{patch};
5932         unless ($patchbin && length $patchbin) {
5933             $CPAN::Frontend->mydie("No external patch command configured\n\n".
5934                                    "Please run 'o conf init /patch/'\n\n");
5935         }
5936         unless (MM->maybe_command($patchbin)) {
5937             $CPAN::Frontend->mydie("No external patch command available\n\n".
5938                                    "Please run 'o conf init /patch/'\n\n");
5939         }
5940         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
5941         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
5942                                    # supported everywhere (and then,
5943                                    # not ever necessary there)
5944         my $stdpatchargs = "-N --fuzz=3";
5945         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
5946         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
5947         for my $patch (@$patches) {
5948             unless (-f $patch) {
5949                 if (my $trydl = $self->try_download($patch)) {
5950                     $patch = $trydl;
5951                 } else {
5952                     my $fail = "Could not find patch '$patch'";
5953                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5954                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5955                     delete $self->{build_dir};
5956                     return;
5957                 }
5958             }
5959             $CPAN::Frontend->myprint("  $patch\n");
5960             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
5961
5962             my $pcommand;
5963             my $ppp = $self->_patch_p_parameter($readfh);
5964             if ($ppp eq "applypatch") {
5965                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
5966             } else {
5967                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
5968                 $pcommand = "$patchbin $thispatchargs";
5969             }
5970
5971             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
5972             my $writefh = FileHandle->new;
5973             $CPAN::Frontend->myprint("  $pcommand\n");
5974             unless (open $writefh, "|$pcommand") {
5975                 my $fail = "Could not fork '$pcommand'";
5976                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5977                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5978                 delete $self->{build_dir};
5979                 return;
5980             }
5981             while (my $x = $readfh->READLINE) {
5982                 print $writefh $x;
5983             }
5984             unless (close $writefh) {
5985                 my $fail = "Could not apply patch '$patch'";
5986                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
5987                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
5988                 delete $self->{build_dir};
5989                 return;
5990             }
5991         }
5992         $self->{patched}++;
5993     }
5994     return 1;
5995 }
5996
5997 sub _patch_p_parameter {
5998     my($self,$fh) = @_;
5999     my $cnt_files   = 0;
6000     my $cnt_p0files = 0;
6001     local($_);
6002     while ($_ = $fh->READLINE) {
6003         if (
6004             $CPAN::Config->{applypatch}
6005             &&
6006             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6007            ) {
6008             return "applypatch"
6009         }
6010         next unless /^[\*\+]{3}\s(\S+)/;
6011         my $file = $1;
6012         $cnt_files++;
6013         $cnt_p0files++ if -f $file;
6014         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6015             if $CPAN::DEBUG;
6016     }
6017     return "-p1" unless $cnt_files;
6018     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6019 }
6020
6021 #-> sub CPAN::Distribution::_edge_cases
6022 # with "configure" or "Makefile" or single file scripts
6023 sub _edge_cases {
6024     my($self,$mpl,$packagedir,$local_file) = @_;
6025     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6026                          $mpl,
6027                          CPAN::anycwd(),
6028                         )) if $CPAN::DEBUG;
6029     my($configure) = File::Spec->catfile($packagedir,"Configure");
6030     if (-f $configure) {
6031         # do we have anything to do?
6032         $self->{configure} = $configure;
6033     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6034         $CPAN::Frontend->mywarn(qq{
6035 Package comes with a Makefile and without a Makefile.PL.
6036 We\'ll try to build it with that Makefile then.
6037 });
6038         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6039         $CPAN::Frontend->mysleep(2);
6040     } else {
6041         my $cf = $self->called_for || "unknown";
6042         if ($cf =~ m|/|) {
6043             $cf =~ s|.*/||;
6044             $cf =~ s|\W.*||;
6045         }
6046         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6047         $cf = "unknown" unless length($cf);
6048         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6049   (The test -f "$mpl" returned false.)
6050   Writing one on our own (setting NAME to $cf)\a\n});
6051         $self->{had_no_makefile_pl}++;
6052         $CPAN::Frontend->mysleep(3);
6053
6054         # Writing our own Makefile.PL
6055
6056         my $script = "";
6057         if ($self->{archived} eq "maybe_pl") {
6058             my $fh = FileHandle->new;
6059             my $script_file = File::Spec->catfile($packagedir,$local_file);
6060             $fh->open($script_file)
6061                 or Carp::croak("Could not open $script_file: $!");
6062             local $/ = "\n";
6063             # name parsen und prereq
6064             my($state) = "poddir";
6065             my($name, $prereq) = ("", "");
6066             while (<$fh>) {
6067                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6068                     if ($1 eq 'NAME') {
6069                         $state = "name";
6070                     } elsif ($1 eq 'PREREQUISITES') {
6071                         $state = "prereq";
6072                     }
6073                 } elsif ($state =~ m{^(name|prereq)$}) {
6074                     if (/^=/) {
6075                         $state = "poddir";
6076                     } elsif (/^\s*$/) {
6077                         # nop
6078                     } elsif ($state eq "name") {
6079                         if ($name eq "") {
6080                             ($name) = /^(\S+)/;
6081                             $state = "poddir";
6082                         }
6083                     } elsif ($state eq "prereq") {
6084                         $prereq .= $_;
6085                     }
6086                 } elsif (/^=cut\b/) {
6087                     last;
6088                 }
6089             }
6090             $fh->close;
6091
6092             for ($name) {
6093                 s{.*<}{};       # strip X<...>
6094                 s{>.*}{};
6095             }
6096             chomp $prereq;
6097             $prereq = join " ", split /\s+/, $prereq;
6098             my($PREREQ_PM) = join("\n", map {
6099                 s{.*<}{};       # strip X<...>
6100                 s{>.*}{};
6101                 if (/[\s\'\"]/) { # prose?
6102                 } else {
6103                     s/[^\w:]$//; # period?
6104                     " "x28 . "'$_' => 0,";
6105                 }
6106             } split /\s*,\s*/, $prereq);
6107
6108             $script = "
6109               EXE_FILES => ['$name'],
6110               PREREQ_PM => {
6111 $PREREQ_PM
6112                            },
6113 ";
6114             if ($name) {
6115                 my $to_file = File::Spec->catfile($packagedir, $name);
6116                 rename $script_file, $to_file
6117                     or die "Can't rename $script_file to $to_file: $!";
6118             }
6119         }
6120
6121         my $fh = FileHandle->new;
6122         $fh->open(">$mpl")
6123             or Carp::croak("Could not open >$mpl: $!");
6124         $fh->print(
6125                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6126 # because there was no Makefile.PL supplied.
6127 # Autogenerated on: }.scalar localtime().qq{
6128
6129 use ExtUtils::MakeMaker;
6130 WriteMakefile(
6131               NAME => q[$cf],$script
6132              );
6133 });
6134         $fh->close;
6135     }
6136 }
6137
6138 #-> CPAN::Distribution::_signature_business
6139 sub _signature_business {
6140     my($self) = @_;
6141     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6142                                                       q{check_sigs});
6143     if ($check_sigs) {
6144         if ($CPAN::META->has_inst("Module::Signature")) {
6145             if (-f "SIGNATURE") {
6146                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6147                 my $rv = Module::Signature::verify();
6148                 if ($rv != Module::Signature::SIGNATURE_OK() and
6149                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6150                     $CPAN::Frontend->mywarn(
6151                                             qq{\nSignature invalid for }.
6152                                             qq{distribution file. }.
6153                                             qq{Please investigate.\n\n}
6154                                            );
6155
6156                     my $wrap =
6157                         sprintf(qq{I'd recommend removing %s. Its signature
6158 is invalid. Maybe you have configured your 'urllist' with
6159 a bad URL. Please check this array with 'o conf urllist', and
6160 retry. For more information, try opening a subshell with
6161   look %s
6162 and there run
6163   cpansign -v
6164 },
6165                                 $self->{localfile},
6166                                 $self->pretty_id,
6167                                );
6168                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6169                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6170                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6171                 } else {
6172                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6173                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6174                 }
6175             } else {
6176                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6177             }
6178         } else {
6179             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6180         }
6181     }
6182 }
6183
6184 #-> CPAN::Distribution::untar_me ;
6185 sub untar_me {
6186     my($self,$ct) = @_;
6187     $self->{archived} = "tar";
6188     if ($ct->untar()) {
6189         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6190     } else {
6191         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6192     }
6193 }
6194
6195 # CPAN::Distribution::unzip_me ;
6196 sub unzip_me {
6197     my($self,$ct) = @_;
6198     $self->{archived} = "zip";
6199     if ($ct->unzip()) {
6200         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6201     } else {
6202         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6203     }
6204     return;
6205 }
6206
6207 sub handle_singlefile {
6208     my($self,$local_file) = @_;
6209
6210     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6211         $self->{archived} = "pm";
6212     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6213         $self->{archived} = "patch";
6214     } else {
6215         $self->{archived} = "maybe_pl";
6216     }
6217
6218     my $to = File::Basename::basename($local_file);
6219     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6220         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6221             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6222         } else {
6223             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6224         }
6225     } else {
6226         if (File::Copy::cp($local_file,".")) {
6227             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6228         } else {
6229             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6230         }
6231     }
6232     return $to;
6233 }
6234
6235 #-> sub CPAN::Distribution::new ;
6236 sub new {
6237     my($class,%att) = @_;
6238
6239     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6240
6241     my $this = { %att };
6242     return bless $this, $class;
6243 }
6244
6245 #-> sub CPAN::Distribution::look ;
6246 sub look {
6247     my($self) = @_;
6248
6249     if ($^O eq 'MacOS') {
6250       $self->Mac::BuildTools::look;
6251       return;
6252     }
6253
6254     if (  $CPAN::Config->{'shell'} ) {
6255         $CPAN::Frontend->myprint(qq{
6256 Trying to open a subshell in the build directory...
6257 });
6258     } else {
6259         $CPAN::Frontend->myprint(qq{
6260 Your configuration does not define a value for subshells.
6261 Please define it with "o conf shell <your shell>"
6262 });
6263         return;
6264     }
6265     my $dist = $self->id;
6266     my $dir;
6267     unless ($dir = $self->dir) {
6268         $self->get;
6269     }
6270     unless ($dir ||= $self->dir) {
6271         $CPAN::Frontend->mywarn(qq{
6272 Could not determine which directory to use for looking at $dist.
6273 });
6274         return;
6275     }
6276     my $pwd  = CPAN::anycwd();
6277     $self->safe_chdir($dir);
6278     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6279     {
6280         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6281         $ENV{CPAN_SHELL_LEVEL} += 1;
6282         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6283         unless (system($shell) == 0) {
6284             my $code = $? >> 8;
6285             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6286         }
6287     }
6288     $self->safe_chdir($pwd);
6289 }
6290
6291 # CPAN::Distribution::cvs_import ;
6292 sub cvs_import {
6293     my($self) = @_;
6294     $self->get;
6295     my $dir = $self->dir;
6296
6297     my $package = $self->called_for;
6298     my $module = $CPAN::META->instance('CPAN::Module', $package);
6299     my $version = $module->cpan_version;
6300
6301     my $userid = $self->cpan_userid;
6302
6303     my $cvs_dir = (split /\//, $dir)[-1];
6304     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6305     my $cvs_root =
6306       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6307     my $cvs_site_perl =
6308       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6309     if ($cvs_site_perl) {
6310         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6311     }
6312     my $cvs_log = qq{"imported $package $version sources"};
6313     $version =~ s/\./_/g;
6314     # XXX cvs: undocumented and unclear how it was meant to work
6315     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6316                "$cvs_dir", $userid, "v$version");
6317
6318     my $pwd  = CPAN::anycwd();
6319     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6320
6321     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6322
6323     $CPAN::Frontend->myprint(qq{@cmd\n});
6324     system(@cmd) == 0 or
6325     # XXX cvs
6326         $CPAN::Frontend->mydie("cvs import failed");
6327     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6328 }
6329
6330 #-> sub CPAN::Distribution::readme ;
6331 sub readme {
6332     my($self) = @_;
6333     my($dist) = $self->id;
6334     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6335     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6336     my($local_file);
6337     my($local_wanted) =
6338          File::Spec->catfile(
6339                              $CPAN::Config->{keep_source_where},
6340                              "authors",
6341                              "id",
6342                              split(/\//,"$sans.readme"),
6343                             );
6344     $self->debug("Doing localize") if $CPAN::DEBUG;
6345     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6346                                       $local_wanted)
6347         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6348
6349     if ($^O eq 'MacOS') {
6350         Mac::BuildTools::launch_file($local_file);
6351         return;
6352     }
6353
6354     my $fh_pager = FileHandle->new;
6355     local($SIG{PIPE}) = "IGNORE";
6356     my $pager = $CPAN::Config->{'pager'} || "cat";
6357     $fh_pager->open("|$pager")
6358         or die "Could not open pager $pager\: $!";
6359     my $fh_readme = FileHandle->new;
6360     $fh_readme->open($local_file)
6361         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6362     $CPAN::Frontend->myprint(qq{
6363 Displaying file
6364   $local_file
6365 with pager "$pager"
6366 });
6367     $fh_pager->print(<$fh_readme>);
6368     $fh_pager->close;
6369 }
6370
6371 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6372 sub verifyCHECKSUM {
6373     my($self) = @_;
6374   EXCUSE: {
6375         my @e;
6376         $self->{CHECKSUM_STATUS} ||= "";
6377         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6378         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6379     }
6380     my($lc_want,$lc_file,@local,$basename);
6381     @local = split(/\//,$self->id);
6382     pop @local;
6383     push @local, "CHECKSUMS";
6384     $lc_want =
6385         File::Spec->catfile($CPAN::Config->{keep_source_where},
6386                             "authors", "id", @local);
6387     local($") = "/";
6388     if (my $size = -s $lc_want) {
6389         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6390         if ($self->CHECKSUM_check_file($lc_want,1)) {
6391             return $self->{CHECKSUM_STATUS} = "OK";
6392         }
6393     }
6394     $lc_file = CPAN::FTP->localize("authors/id/@local",
6395                                    $lc_want,1);
6396     unless ($lc_file) {
6397         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6398         $local[-1] .= ".gz";
6399         $lc_file = CPAN::FTP->localize("authors/id/@local",
6400                                        "$lc_want.gz",1);
6401         if ($lc_file) {
6402             $lc_file =~ s/\.gz(?!\n)\Z//;
6403             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6404         } else {
6405             return;
6406         }
6407     }
6408     if ($self->CHECKSUM_check_file($lc_file)) {
6409         return $self->{CHECKSUM_STATUS} = "OK";
6410     }
6411 }
6412
6413 #-> sub CPAN::Distribution::SIG_check_file ;
6414 sub SIG_check_file {
6415     my($self,$chk_file) = @_;
6416     my $rv = eval { Module::Signature::_verify($chk_file) };
6417
6418     if ($rv == Module::Signature::SIGNATURE_OK()) {
6419         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6420         return $self->{SIG_STATUS} = "OK";
6421     } else {
6422         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6423                                  qq{distribution file. }.
6424                                  qq{Please investigate.\n\n}.
6425                                  $self->as_string,
6426                                 $CPAN::META->instance(
6427                                                         'CPAN::Author',
6428                                                         $self->cpan_userid
6429                                                         )->as_string);
6430
6431         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6432 is invalid. Maybe you have configured your 'urllist' with
6433 a bad URL. Please check this array with 'o conf urllist', and
6434 retry.};
6435
6436         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6437     }
6438 }
6439
6440 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6441
6442 # sloppy is 1 when we have an old checksums file that maybe is good
6443 # enough
6444
6445 sub CHECKSUM_check_file {
6446     my($self,$chk_file,$sloppy) = @_;
6447     my($cksum,$file,$basename);
6448
6449     $sloppy ||= 0;
6450     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6451     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6452                                                       q{check_sigs});
6453     if ($check_sigs) {
6454         if ($CPAN::META->has_inst("Module::Signature")) {
6455             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6456             $self->SIG_check_file($chk_file);
6457         } else {
6458             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6459         }
6460     }
6461
6462     $file = $self->{localfile};
6463     $basename = File::Basename::basename($file);
6464     my $fh = FileHandle->new;
6465     if (open $fh, $chk_file){
6466         local($/);
6467         my $eval = <$fh>;
6468         $eval =~ s/\015?\012/\n/g;
6469         close $fh;
6470         my($comp) = Safe->new();
6471         $cksum = $comp->reval($eval);
6472         if ($@) {
6473             rename $chk_file, "$chk_file.bad";
6474             Carp::confess($@) if $@;
6475         }
6476     } else {
6477         Carp::carp "Could not open $chk_file for reading";
6478     }
6479
6480     if (! ref $cksum or ref $cksum ne "HASH") {
6481         $CPAN::Frontend->mywarn(qq{
6482 Warning: checksum file '$chk_file' broken.
6483
6484 When trying to read that file I expected to get a hash reference
6485 for further processing, but got garbage instead.
6486 });
6487         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6488         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6489         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6490         return;
6491     } elsif (exists $cksum->{$basename}{sha256}) {
6492         $self->debug("Found checksum for $basename:" .
6493                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6494
6495         open($fh, $file);
6496         binmode $fh;
6497         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6498         $fh->close;
6499         $fh = CPAN::Tarzip->TIEHANDLE($file);
6500
6501         unless ($eq) {
6502           my $dg = Digest::SHA->new(256);
6503           my($data,$ref);
6504           $ref = \$data;
6505           while ($fh->READ($ref, 4096) > 0){
6506             $dg->add($data);
6507           }
6508           my $hexdigest = $dg->hexdigest;
6509           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6510         }
6511
6512         if ($eq) {
6513           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6514           return $self->{CHECKSUM_STATUS} = "OK";
6515         } else {
6516             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6517                                      qq{distribution file. }.
6518                                      qq{Please investigate.\n\n}.
6519                                      $self->as_string,
6520                                      $CPAN::META->instance(
6521                                                            'CPAN::Author',
6522                                                            $self->cpan_userid
6523                                                           )->as_string);
6524
6525             my $wrap = qq{I\'d recommend removing $file. Its
6526 checksum is incorrect. Maybe you have configured your 'urllist' with
6527 a bad URL. Please check this array with 'o conf urllist', and
6528 retry.};
6529
6530             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6531
6532             # former versions just returned here but this seems a
6533             # serious threat that deserves a die
6534
6535             # $CPAN::Frontend->myprint("\n\n");
6536             # sleep 3;
6537             # return;
6538         }
6539         # close $fh if fileno($fh);
6540     } else {
6541         return if $sloppy;
6542         unless ($self->{CHECKSUM_STATUS}) {
6543             $CPAN::Frontend->mywarn(qq{
6544 Warning: No checksum for $basename in $chk_file.
6545
6546 The cause for this may be that the file is very new and the checksum
6547 has not yet been calculated, but it may also be that something is
6548 going awry right now.
6549 });
6550             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6551             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6552         }
6553         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6554         return;
6555     }
6556 }
6557
6558 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6559 sub eq_CHECKSUM {
6560     my($self,$fh,$expect) = @_;
6561     if ($CPAN::META->has_inst("Digest::SHA")) {
6562         my $dg = Digest::SHA->new(256);
6563         my($data);
6564         while (read($fh, $data, 4096)){
6565             $dg->add($data);
6566         }
6567         my $hexdigest = $dg->hexdigest;
6568         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6569         return $hexdigest eq $expect;
6570     }
6571     return 1;
6572 }
6573
6574 #-> sub CPAN::Distribution::force ;
6575
6576 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6577 # effect by autoinspection, not by inspecting a global variable. One
6578 # of the reason why this was chosen to work that way was the treatment
6579 # of dependencies. They should not automatically inherit the force
6580 # status. But this has the downside that ^C and die() will return to
6581 # the prompt but will not be able to reset the force_update
6582 # attributes. We try to correct for it currently in the read_metadata
6583 # routine, and immediately before we check for a Signal. I hope this
6584 # works out in one of v1.57_53ff
6585
6586 # "Force get forgets previous error conditions"
6587
6588 #-> sub CPAN::Distribution::fforce ;
6589 sub fforce {
6590   my($self, $method) = @_;
6591   $self->force($method,1);
6592 }
6593
6594 #-> sub CPAN::Distribution::force ;
6595 sub force {
6596   my($self, $method,$fforce) = @_;
6597   my %phase_map = (
6598                    get => [
6599                            "unwrapped",
6600                            "build_dir",
6601                            "archived",
6602                            "localfile",
6603                            "CHECKSUM_STATUS",
6604                            "signature_verify",
6605                            "prefs",
6606                            "prefs_file",
6607                            "prefs_file_doc",
6608                           ],
6609                    make => [
6610                             "writemakefile",
6611                             "make",
6612                             "modulebuild",
6613                             "prereq_pm",
6614                             "prereq_pm_detected",
6615                            ],
6616                    test => [
6617                             "badtestcnt",
6618                             "make_test",
6619                            ],
6620                    install => [
6621                                "install",
6622                               ],
6623                    unknown => [
6624                                "reqtype",
6625                                "yaml_content",
6626                               ],
6627                   );
6628   my $methodmatch = 0;
6629   my $ldebug = 0;
6630  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6631       $methodmatch = 1 if $fforce || $phase eq $method;
6632       next unless $methodmatch;
6633     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6634           if ($phase eq "get") {
6635               if (substr($self->id,-1,1) eq "."
6636                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6637                   # cannot be undone for local distros
6638                   next ATTRIBUTE;
6639               }
6640               if ($att eq "build_dir"
6641                   && $self->{build_dir}
6642                   && $CPAN::META->{is_tested}
6643                  ) {
6644                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6645               }
6646           } elsif ($phase eq "test") {
6647               if ($att eq "make_test"
6648                   && $self->{make_test}
6649                   && $self->{make_test}{COMMANDID}
6650                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6651                  ) {
6652                   # endless loop too likely
6653                   next ATTRIBUTE;
6654               }
6655           }
6656           delete $self->{$att};
6657           if ($ldebug || $CPAN::DEBUG) {
6658               # local $CPAN::DEBUG = 16; # Distribution
6659               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6660           }
6661       }
6662   }
6663   if ($method && $method =~ /make|test|install/) {
6664     $self->{force_update} = 1; # name should probably have been force_install
6665   }
6666 }
6667
6668 #-> sub CPAN::Distribution::notest ;
6669 sub notest {
6670   my($self, $method) = @_;
6671   # warn "XDEBUG: set notest for $self $method";
6672   $self->{"notest"}++; # name should probably have been force_install
6673 }
6674
6675 #-> sub CPAN::Distribution::unnotest ;
6676 sub unnotest {
6677   my($self) = @_;
6678   # warn "XDEBUG: deleting notest";
6679   delete $self->{'notest'};
6680 }
6681
6682 #-> sub CPAN::Distribution::unforce ;
6683 sub unforce {
6684   my($self) = @_;
6685   delete $self->{force_update};
6686 }
6687
6688 #-> sub CPAN::Distribution::isa_perl ;
6689 sub isa_perl {
6690   my($self) = @_;
6691   my $file = File::Basename::basename($self->id);
6692   if ($file =~ m{ ^ perl
6693                   -?
6694                   (5)
6695                   ([._-])
6696                   (
6697                    \d{3}(_[0-4][0-9])?
6698                    |
6699                    \d+\.\d+
6700                   )
6701                   \.tar[._-](?:gz|bz2)
6702                   (?!\n)\Z
6703                 }xs){
6704     return "$1.$3";
6705   } elsif ($self->cpan_comment
6706            &&
6707            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6708     return $1;
6709   }
6710 }
6711
6712
6713 #-> sub CPAN::Distribution::perl ;
6714 sub perl {
6715     my ($self) = @_;
6716     if (! $self) {
6717         use Carp qw(carp);
6718         carp __PACKAGE__ . "::perl was called without parameters.";
6719     }
6720     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6721 }
6722
6723
6724 #-> sub CPAN::Distribution::make ;
6725 sub make {
6726     my($self) = @_;
6727     if (my $goto = $self->prefs->{goto}) {
6728         return $self->goto($goto);
6729     }
6730     my $make = $self->{modulebuild} ? "Build" : "make";
6731     # Emergency brake if they said install Pippi and get newest perl
6732     if ($self->isa_perl) {
6733       if (
6734           $self->called_for ne $self->id &&
6735           ! $self->{force_update}
6736          ) {
6737         # if we die here, we break bundles
6738         $CPAN::Frontend
6739             ->mywarn(sprintf(
6740                              qq{The most recent version "%s" of the module "%s"
6741 is part of the perl-%s distribution. To install that, you need to run
6742   force install %s   --or--
6743   install %s
6744 },
6745                              $CPAN::META->instance(
6746                                                    'CPAN::Module',
6747                                                    $self->called_for
6748                                                   )->cpan_version,
6749                              $self->called_for,
6750                              $self->isa_perl,
6751                              $self->called_for,
6752                              $self->id,
6753                             ));
6754         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6755         $CPAN::Frontend->mysleep(1);
6756         return;
6757       }
6758     }
6759     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6760     $self->get;
6761     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6762                            ? $ENV{PERL5LIB}
6763                            : ($ENV{PERLLIB} || "");
6764     $CPAN::META->set_perl5lib;
6765     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6766
6767     if ($CPAN::Signal){
6768       delete $self->{force_update};
6769       return;
6770     }
6771
6772     my $builddir;
6773   EXCUSE: {
6774         my @e;
6775         if (!$self->{archived} || $self->{archived} eq "NO") {
6776             push @e, "Is neither a tar nor a zip archive.";
6777         }
6778
6779         if (!$self->{unwrapped}
6780             || (
6781                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6782                 $self->{unwrapped}->failed :
6783                 $self->{unwrapped} =~ /^NO/
6784                )) {
6785             push @e, "Had problems unarchiving. Please build manually";
6786         }
6787
6788         unless ($self->{force_update}) {
6789             exists $self->{signature_verify} and
6790                 (
6791                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6792                  $self->{signature_verify}->failed :
6793                  $self->{signature_verify} =~ /^NO/
6794                 )
6795                 and push @e, "Did not pass the signature test.";
6796         }
6797
6798         if (exists $self->{writemakefile} &&
6799             (
6800              UNIVERSAL::can($self->{writemakefile},"failed") ?
6801              $self->{writemakefile}->failed :
6802              $self->{writemakefile} =~ /^NO/
6803             )) {
6804             # XXX maybe a retry would be in order?
6805             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6806                 $self->{writemakefile}->text :
6807                     $self->{writemakefile};
6808             $err =~ s/^NO\s*//;
6809             $err ||= "Had some problem writing Makefile";
6810             $err .= ", won't make";
6811             push @e, $err;
6812         }
6813
6814         defined $self->{make} and push @e,
6815             "Has already been made";
6816
6817         if (exists $self->{later} and length($self->{later})) {
6818             if ($self->unsat_prereq) {
6819                 push @e, $self->{later};
6820 # RT ticket 18438 raises doubts if the deletion of {later} is valid.
6821 # YAML-0.53 triggered the later hodge-podge here, but my margin notes
6822 # are not sufficient to be sure if we really must/may do the delete
6823 # here. SO I accept the suggested patch for now. If we trigger a bug
6824 # again, I must go into deep contemplation about the {later} flag.
6825
6826 #            } else {
6827 #                delete $self->{later};
6828             }
6829         }
6830
6831         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6832         $builddir = $self->dir or
6833             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6834         unless (chdir $builddir) {
6835             push @e, "Couldn't chdir to '$builddir': $!";
6836         }
6837         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6838     }
6839     if ($CPAN::Signal){
6840       delete $self->{force_update};
6841       return;
6842     }
6843     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6844     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6845
6846     if ($^O eq 'MacOS') {
6847         Mac::BuildTools::make($self);
6848         return;
6849     }
6850
6851     my %env;
6852     while (my($k,$v) = each %ENV) {
6853         next unless defined $v;
6854         $env{$k} = $v;
6855     }
6856     local %ENV = %env;
6857     my $system;
6858     if (my $commandline = $self->prefs->{pl}{commandline}) {
6859         $system = $commandline;
6860         $ENV{PERL} = $^X;
6861     } elsif ($self->{'configure'}) {
6862         $system = $self->{'configure'};
6863     } elsif ($self->{modulebuild}) {
6864         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6865         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6866     } else {
6867         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6868         my $switch = "";
6869 # This needs a handler that can be turned on or off:
6870 #       $switch = "-MExtUtils::MakeMaker ".
6871 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6872 #           if $] > 5.00310;
6873         my $makepl_arg = $self->make_x_arg("pl");
6874         $system = sprintf("%s%s Makefile.PL%s",
6875                           $perl,
6876                           $switch ? " $switch" : "",
6877                           $makepl_arg ? " $makepl_arg" : "",
6878                          );
6879     }
6880     if (my $env = $self->prefs->{pl}{env}) {
6881         for my $e (keys %$env) {
6882             $ENV{$e} = $env->{$e};
6883         }
6884     }
6885     if (exists $self->{writemakefile}) {
6886     } else {
6887         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
6888         my($ret,$pid);
6889         $@ = "";
6890         my $go_via_alarm;
6891         if ($CPAN::Config->{inactivity_timeout}) {
6892             require Config;
6893             if ($Config::Config{d_alarm}
6894                 &&
6895                 $Config::Config{d_alarm} eq "define"
6896                ) {
6897                 $go_via_alarm++
6898             } else {
6899                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
6900                                         "variable 'inactivity_timeout' to ".
6901                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
6902                                         "on this machine the system call 'alarm' ".
6903                                         "isn't available. This means that we cannot ".
6904                                         "provide the feature of intercepting long ".
6905                                         "waiting code and will turn this feature off.\n"
6906                                        );
6907                 $CPAN::Config->{inactivity_timeout} = 0;
6908             }
6909         }
6910         if ($go_via_alarm) {
6911             eval {
6912                 alarm $CPAN::Config->{inactivity_timeout};
6913                 local $SIG{CHLD}; # = sub { wait };
6914                 if (defined($pid = fork)) {
6915                     if ($pid) { #parent
6916                         # wait;
6917                         waitpid $pid, 0;
6918                     } else {    #child
6919                         # note, this exec isn't necessary if
6920                         # inactivity_timeout is 0. On the Mac I'd
6921                         # suggest, we set it always to 0.
6922                         exec $system;
6923                     }
6924                 } else {
6925                     $CPAN::Frontend->myprint("Cannot fork: $!");
6926                     return;
6927                 }
6928             };
6929             alarm 0;
6930             if ($@){
6931                 kill 9, $pid;
6932                 waitpid $pid, 0;
6933                 my $err = "$@";
6934                 $CPAN::Frontend->myprint($err);
6935                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
6936                 $@ = "";
6937                 return;
6938             }
6939         } else {
6940             if (my $expect_model = $self->_prefs_with_expect("pl")) {
6941                 $ret = $self->_run_via_expect($system,$expect_model);
6942                 if (! defined $ret
6943                     && $self->{writemakefile}
6944                     && $self->{writemakefile}->failed) {
6945                     # timeout
6946                     return;
6947                 }
6948             } else {
6949                 $ret = system($system);
6950             }
6951             if ($ret != 0) {
6952                 $self->{writemakefile} = CPAN::Distrostatus
6953                     ->new("NO '$system' returned status $ret");
6954                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
6955                 $self->store_persistent_state;
6956                 $self->store_persistent_state;
6957                 return;
6958             }
6959         }
6960         if (-f "Makefile" || -f "Build") {
6961           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6962           delete $self->{make_clean}; # if cleaned before, enable next
6963         } else {
6964           $self->{writemakefile} = CPAN::Distrostatus
6965               ->new(qq{NO -- Unknown reason});
6966         }
6967     }
6968     if ($CPAN::Signal){
6969       delete $self->{force_update};
6970       return;
6971     }
6972     if (my @prereq = $self->unsat_prereq){
6973         if ($prereq[0][0] eq "perl") {
6974             my $need = "requires perl '$prereq[0][1]'";
6975             my $id = $self->pretty_id;
6976             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
6977             $self->{make} = CPAN::Distrostatus->new("NO $need");
6978             $self->store_persistent_state;
6979             return;
6980         } else {
6981             return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
6982         }
6983     }
6984     if ($CPAN::Signal){
6985       delete $self->{force_update};
6986       return;
6987     }
6988     if (my $commandline = $self->prefs->{make}{commandline}) {
6989         $system = $commandline;
6990         $ENV{PERL} = $^X;
6991     } else {
6992         if ($self->{modulebuild}) {
6993             unless (-f "Build") {
6994                 my $cwd = CPAN::anycwd();
6995                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
6996                                         " in cwd[$cwd]. Danger, Will Robinson!");
6997                 $CPAN::Frontend->mysleep(5);
6998             }
6999             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7000         } else {
7001             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7002         }
7003         $system =~ s/\s+$//;
7004         my $make_arg = $self->make_x_arg("make");
7005         $system = sprintf("%s%s",
7006                           $system,
7007                           $make_arg ? " $make_arg" : "",
7008                          );
7009     }
7010     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7011                                                # ENV of PL, not the
7012                                                # outer ENV, but
7013                                                # unlikely to be a risk
7014         for my $e (keys %$env) {
7015             $ENV{$e} = $env->{$e};
7016         }
7017     }
7018     my $expect_model = $self->_prefs_with_expect("make");
7019     my $want_expect = 0;
7020     if ( $expect_model && @{$expect_model->{talk}} ) {
7021         my $can_expect = $CPAN::META->has_inst("Expect");
7022         if ($can_expect) {
7023             $want_expect = 1;
7024         } else {
7025             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7026                                     "system()\n");
7027         }
7028     }
7029     my $system_ok;
7030     if ($want_expect) {
7031         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7032     } else {
7033         $system_ok = system($system) == 0;
7034     }
7035     $self->introduce_myself;
7036     if ( $system_ok ) {
7037          $CPAN::Frontend->myprint("  $system -- OK\n");
7038          $self->{make} = CPAN::Distrostatus->new("YES");
7039     } else {
7040          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7041          $self->{make} = CPAN::Distrostatus->new("NO");
7042          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7043     }
7044     $self->store_persistent_state;
7045 }
7046
7047 # CPAN::Distribution::_run_via_expect
7048 sub _run_via_expect {
7049     my($self,$system,$expect_model) = @_;
7050     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7051     if ($CPAN::META->has_inst("Expect")) {
7052         my $expo = Expect->new;  # expo Expect object;
7053         $expo->spawn($system);
7054         $expect_model->{mode} ||= "deterministic";
7055         if ($expect_model->{mode} eq "deterministic") {
7056             return $self->_run_via_expect_deterministic($expo,$expect_model);
7057         } elsif ($expect_model->{mode} eq "anyorder") {
7058             return $self->_run_via_expect_anyorder($expo,$expect_model);
7059         } else {
7060             die "Panic: Illegal expect mode: $expect_model->{mode}";
7061         }
7062     } else {
7063         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7064         return system($system);
7065     }
7066 }
7067
7068 sub _run_via_expect_anyorder {
7069     my($self,$expo,$expect_model) = @_;
7070     my $timeout = $expect_model->{timeout} || 5;
7071     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7072     my $but = "";
7073   EXPECT: while () {
7074         my($eof,$ran_into_timeout);
7075         my @match = $expo->expect($timeout,
7076                                   [ eof => sub {
7077                                         $eof++;
7078                                     } ],
7079                                   [ timeout => sub {
7080                                         $ran_into_timeout++;
7081                                     } ],
7082                                   -re => eval"qr{.}",
7083                                  );
7084         if ($match[2]) {
7085             $but .= $match[2];
7086         }
7087         $but .= $expo->clear_accum;
7088         if ($eof) {
7089             $expo->soft_close;
7090             return $expo->exitstatus();
7091         } elsif ($ran_into_timeout) {
7092             # warn "DEBUG: they are asking a question, but[$but]";
7093             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7094                 my($next,$send) = @expectacopy[$i,$i+1];
7095                 my $regex = eval "qr{$next}";
7096                 # warn "DEBUG: will compare with regex[$regex].";
7097                 if ($but =~ /$regex/) {
7098                     # warn "DEBUG: will send send[$send]";
7099                     $expo->send($send);
7100                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7101                     next EXPECT;
7102                 }
7103             }
7104             my $why = "could not answer a question during the dialog";
7105             $CPAN::Frontend->mywarn("Failing: $why\n");
7106             $self->{writemakefile} =
7107                 CPAN::Distrostatus->new("NO $why");
7108             return;
7109         }
7110     }
7111 }
7112
7113 sub _run_via_expect_deterministic {
7114     my($self,$expo,$expect_model) = @_;
7115     my $ran_into_timeout;
7116     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7117     my $expecta = $expect_model->{talk};
7118   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7119         my($re,$send) = @$expecta[$i,$i+1];
7120         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7121         my $regex = eval "qr{$re}";
7122         $expo->expect($timeout,
7123                       [ eof => sub {
7124                             my $but = $expo->clear_accum;
7125                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7126 expected[$regex]\nbut[$but]\n\n");
7127                             last EXPECT;
7128                         } ],
7129                       [ timeout => sub {
7130                             my $but = $expo->clear_accum;
7131                             $CPAN::Frontend->mywarn("TIMEOUT
7132 expected[$regex]\nbut[$but]\n\n");
7133                             $ran_into_timeout++;
7134                         } ],
7135                       -re => $regex);
7136         if ($ran_into_timeout){
7137             # note that the caller expects 0 for success
7138             $self->{writemakefile} =
7139                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7140             return;
7141         }
7142         $expo->send($send);
7143     }
7144     $expo->soft_close;
7145     return $expo->exitstatus();
7146 }
7147
7148 #-> CPAN::Distribution::_validate_distropref
7149 sub _validate_distropref {
7150     my($self,@args) = @_;
7151     if (
7152         $CPAN::META->has_inst("CPAN::Kwalify")
7153         &&
7154         $CPAN::META->has_inst("Kwalify")
7155        ) {
7156         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7157         if ($@) {
7158             $CPAN::Frontend->mywarn($@);
7159         }
7160     } else {
7161         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7162     }
7163 }
7164
7165 #-> CPAN::Distribution::_find_prefs
7166 sub _find_prefs {
7167     my($self) = @_;
7168     my $distroid = $self->pretty_id;
7169     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7170     my $prefs_dir = $CPAN::Config->{prefs_dir};
7171     eval { File::Path::mkpath($prefs_dir); };
7172     if ($@) {
7173         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7174     }
7175     my $yaml_module = CPAN::_yaml_module;
7176     my @extensions;
7177     if ($CPAN::META->has_inst($yaml_module)) {
7178         push @extensions, "yml";
7179     } else {
7180         my @fallbacks;
7181         if ($CPAN::META->has_inst("Data::Dumper")) {
7182             push @extensions, "dd";
7183             push @fallbacks, "Data::Dumper";
7184         }
7185         if ($CPAN::META->has_inst("Storable")) {
7186             push @extensions, "st";
7187             push @fallbacks, "Storable";
7188         }
7189         if (@fallbacks) {
7190             local $" = " and ";
7191             unless ($self->{have_complained_about_missing_yaml}++) {
7192                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7193                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7194             }
7195         } else {
7196             unless ($self->{have_complained_about_missing_yaml}++) {
7197                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7198                                         "read prefs '$prefs_dir'\n");
7199             }
7200         }
7201     }
7202     if (@extensions) {
7203         my $dh = DirHandle->new($prefs_dir)
7204             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7205       DIRENT: for (sort $dh->read) {
7206             next if $_ eq "." || $_ eq "..";
7207             my $exte = join "|", @extensions;
7208             next unless /\.($exte)$/;
7209             my $thisexte = $1;
7210             my $abs = File::Spec->catfile($prefs_dir, $_);
7211             if (-f $abs) {
7212                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7213                 my @distropref;
7214                 if ($thisexte eq "yml") {
7215                     # need no eval because if we have no YAML we do not try to read *.yml
7216                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7217                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7218                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7219                 } elsif ($thisexte eq "dd") {
7220                     package CPAN::Eval;
7221                     no strict;
7222                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7223                     local $/;
7224                     my $eval = <FH>;
7225                     close FH;
7226                     eval $eval;
7227                     if ($@) {
7228                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7229                     }
7230                     my $i = 1;
7231                     while (${"VAR".$i}) {
7232                         push @distropref, ${"VAR".$i};
7233                         $i++;
7234                     }
7235                 } elsif ($thisexte eq "st") {
7236                     # eval because Storable is never forward compatible
7237                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7238                     if ($@) {
7239                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7240                                                 "$_, skipping\: $@");
7241                         $CPAN::Frontend->mysleep(4);
7242                         next DIRENT;
7243                     }
7244                 }
7245                 # $DB::single=1;
7246                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7247               ELEMENT: for my $y (0..$#distropref) {
7248                     my $distropref = $distropref[$y];
7249                     $self->_validate_distropref($distropref,$abs,$y);
7250                     my $match = $distropref->{match};
7251                     unless ($match) {
7252                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7253                         next ELEMENT;
7254                     }
7255                     my $ok = 1;
7256                     # do not take the order of C<keys %$match> because
7257                     # "module" is by far the slowest
7258                     my $saw_valid_subkeys = 0;
7259                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7260                         next unless exists $match->{$sub_attribute};
7261                         $saw_valid_subkeys++;
7262                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7263                         if ($sub_attribute eq "module") {
7264                             my $okm = 0;
7265                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7266                             my @modules = $self->containsmods;
7267                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7268                           MODULE: for my $module (@modules) {
7269                                 $okm ||= $module =~ /$qr/;
7270                                 last MODULE if $okm;
7271                             }
7272                             $ok &&= $okm;
7273                         } elsif ($sub_attribute eq "distribution") {
7274                             my $okd = $distroid =~ /$qr/;
7275                             $ok &&= $okd;
7276                         } elsif ($sub_attribute eq "perl") {
7277                             my $okp = $^X =~ /$qr/;
7278                             $ok &&= $okp;
7279                         } elsif ($sub_attribute eq "perlconfig") {
7280                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7281                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7282                                 # XXX should probably warn if Config does not exist
7283                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7284                                 $ok &&= $okpc;
7285                                 last if $ok == 0;
7286                             }
7287                         } else {
7288                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7289                                                    "unknown sub_attribut '$sub_attribute'. ".
7290                                                    "Please ".
7291                                                    "remove, cannot continue.");
7292                         }
7293                         last if $ok == 0; # short circuit
7294                     }
7295                     unless ($saw_valid_subkeys) {
7296                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7297                                                "missing match/* subattribute. ".
7298                                                "Please ".
7299                                                "remove, cannot continue.");
7300                     }
7301                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7302                     if ($ok) {
7303                         return {
7304                                 prefs => $distropref,
7305                                 prefs_file => $abs,
7306                                 prefs_file_doc => $y,
7307                                };
7308                     }
7309
7310                 }
7311             }
7312         }
7313         $dh->close;
7314     }
7315     return;
7316 }
7317
7318 # CPAN::Distribution::prefs
7319 sub prefs {
7320     my($self) = @_;
7321     if (exists $self->{negative_prefs_cache}
7322         &&
7323         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7324        ) {
7325         delete $self->{negative_prefs_cache};
7326         delete $self->{prefs};
7327     }
7328     if (exists $self->{prefs}) {
7329         return $self->{prefs}; # XXX comment out during debugging
7330     }
7331     if ($CPAN::Config->{prefs_dir}) {
7332         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7333         my $prefs = $self->_find_prefs();
7334         $prefs ||= ""; # avoid warning next line
7335         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7336         if ($prefs) {
7337             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7338                 $self->{$x} = $prefs->{$x};
7339             }
7340             my $bs = sprintf(
7341                              "%s[%s]",
7342                              File::Basename::basename($self->{prefs_file}),
7343                              $self->{prefs_file_doc},
7344                             );
7345             my $filler1 = "_" x 22;
7346             my $filler2 = int(66 - length($bs))/2;
7347             $filler2 = 0 if $filler2 < 0;
7348             $filler2 = " " x $filler2;
7349             $CPAN::Frontend->myprint("
7350 $filler1 D i s t r o P r e f s $filler1
7351 $filler2 $bs $filler2
7352 ");
7353             $CPAN::Frontend->mysleep(1);
7354             return $self->{prefs};
7355         }
7356     }
7357     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7358     return $self->{prefs} = +{};
7359 }
7360
7361 # CPAN::Distribution::make_x_arg
7362 sub make_x_arg {
7363     my($self, $whixh) = @_;
7364     my $make_x_arg;
7365     my $prefs = $self->prefs;
7366     if (
7367         $prefs
7368         && exists $prefs->{$whixh}
7369         && exists $prefs->{$whixh}{args}
7370         && $prefs->{$whixh}{args}
7371        ) {
7372         $make_x_arg = join(" ",
7373                            map {CPAN::HandleConfig
7374                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7375                           );
7376     }
7377     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7378     $make_x_arg ||= $CPAN::Config->{$what};
7379     return $make_x_arg;
7380 }
7381
7382 # CPAN::Distribution::_make_command
7383 sub _make_command {
7384     my ($self) = @_;
7385     if ($self) {
7386         return
7387             CPAN::HandleConfig
7388                 ->safe_quote(
7389                              CPAN::HandleConfig->prefs_lookup($self,
7390                                                               q{make})
7391                              || $Config::Config{make}
7392                              || 'make'
7393                             );
7394     } else {
7395         # Old style call, without object. Deprecated
7396         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7397         return
7398           safe_quote(undef,
7399                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7400                      || $CPAN::Config->{make}
7401                      || $Config::Config{make}
7402                      || 'make');
7403     }
7404 }
7405
7406 #-> sub CPAN::Distribution::follow_prereqs ;
7407 sub follow_prereqs {
7408     my($self) = shift;
7409     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7410     return unless @prereq_tuples;
7411     my @prereq = map { $_->[0] } @prereq_tuples;
7412     my $pretty_id = $self->pretty_id;
7413     my %map = (
7414                b => "build_requires",
7415                r => "requires",
7416                c => "commandline",
7417               );
7418     my($filler1,$filler2,$filler3,$filler4);
7419     # $DB::single=1;
7420     my $unsat = "Unsatisfied dependencies detected during";
7421     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7422     {
7423         my $r = int(($w - length($unsat))/2);
7424         my $l = $w - length($unsat) - $r;
7425         $filler1 = "-"x4 . " "x$l;
7426         $filler2 = " "x$r . "-"x4 . "\n";
7427     }
7428     {
7429         my $r = int(($w - length($pretty_id))/2);
7430         my $l = $w - length($pretty_id) - $r;
7431         $filler3 = "-"x4 . " "x$l;
7432         $filler4 = " "x$r . "-"x4 . "\n";
7433     }
7434     $CPAN::Frontend->
7435         myprint("$filler1 $unsat $filler2".
7436                 "$filler3 $pretty_id $filler4".
7437                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7438                );
7439     my $follow = 0;
7440     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7441         $follow = 1;
7442     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7443         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7444 "Shall I follow them and prepend them to the queue
7445 of modules we are processing right now?", "yes");
7446         $follow = $answer =~ /^\s*y/i;
7447     } else {
7448         local($") = ", ";
7449         $CPAN::Frontend->
7450             myprint("  Ignoring dependencies on modules @prereq\n");
7451     }
7452     if ($follow) {
7453         my $id = $self->id;
7454         # color them as dirty
7455         for my $p (@prereq) {
7456             # warn "calling color_cmd_tmps(0,1)";
7457             my $any = CPAN::Shell->expandany($p);
7458             if ($any) {
7459                 $any->color_cmd_tmps(0,2);
7460             } else {
7461                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7462                 $CPAN::Frontend->mysleep(2);
7463             }
7464         }
7465         # queue them and re-queue yourself
7466         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7467                                reverse @prereq_tuples);
7468         $self->{later} = "Delayed until after prerequisites";
7469         return 1; # signal success to the queuerunner
7470     }
7471 }
7472
7473 #-> sub CPAN::Distribution::unsat_prereq ;
7474 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7475 # return ([perl=>5.008]) if we need a newer perl than we are running under
7476 sub unsat_prereq {
7477     my($self) = @_;
7478     my $prereq_pm = $self->prereq_pm or return;
7479     my(@need);
7480     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7481     my @merged = %merged;
7482     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7483   NEED: while (my($need_module, $need_version) = each %merged) {
7484         my($available_version,$available_file,$nmo);
7485         if ($need_module eq "perl") {
7486             $available_version = $];
7487             $available_file = $^X;
7488         } else {
7489             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7490             next if $nmo->uptodate;
7491             $available_file = $nmo->available_file;
7492
7493             # if they have not specified a version, we accept any installed one
7494             if (not defined $need_version or
7495                 $need_version == 0 or
7496                 $need_version eq "undef") {
7497                 next if defined $available_file;
7498             }
7499
7500             $available_version = $nmo->available_version;
7501         }
7502
7503         # We only want to install prereqs if either they're not installed
7504         # or if the installed version is too old. We cannot omit this
7505         # check, because if 'force' is in effect, nobody else will check.
7506         if (defined $available_file) {
7507             my(@all_requirements) = split /\s*,\s*/, $need_version;
7508             local($^W) = 0;
7509             my $ok = 0;
7510           RQ: for my $rq (@all_requirements) {
7511                 if ($rq =~ s|>=\s*||) {
7512                 } elsif ($rq =~ s|>\s*||) {
7513                     # 2005-12: one user
7514                     if (CPAN::Version->vgt($available_version,$rq)){
7515                         $ok++;
7516                     }
7517                     next RQ;
7518                 } elsif ($rq =~ s|!=\s*||) {
7519                     # 2005-12: no user
7520                     if (CPAN::Version->vcmp($available_version,$rq)){
7521                         $ok++;
7522                         next RQ;
7523                     } else {
7524                         last RQ;
7525                     }
7526                 } elsif ($rq =~ m|<=?\s*|) {
7527                     # 2005-12: no user
7528                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7529                     $ok++;
7530                     next RQ;
7531                 }
7532                 if (! CPAN::Version->vgt($rq, $available_version)){
7533                     $ok++;
7534                 }
7535                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7536                                     "available_version[%s]rq[%s]ok[%d]",
7537                                     $need_module,
7538                                     $available_file,
7539                                     $available_version,
7540                                     CPAN::Version->readable($rq),
7541                                     $ok,
7542                                    )) if $CPAN::DEBUG;
7543             }
7544             next NEED if $ok == @all_requirements;
7545         }
7546
7547         if ($need_module eq "perl") {
7548             return ["perl", $need_version];
7549         }
7550         if ($self->{sponsored_mods}{$need_module}++){
7551             # We have already sponsored it and for some reason it's still
7552             # not available. So we do ... what??
7553
7554             # if we push it again, we have a potential infinite loop
7555
7556             # The following "next" was a very problematic construct.
7557             # It helped a lot but broke some day and must be replaced.
7558
7559             # We must be able to deal with modules that come again and
7560             # again as a prereq and have themselves prereqs and the
7561             # queue becomes long but finally we would find the correct
7562             # order. The RecursiveDependency check should trigger a
7563             # die when it's becoming too weird. Unfortunately removing
7564             # this next breaks many other things.
7565
7566             # The bug that brought this up is described in Todo under
7567             # "5.8.9 cannot install Compress::Zlib"
7568
7569             # next; # this is the next that must go away
7570
7571             # The following "next NEED" are fine and the error message
7572             # explains well what is going on. For example when the DBI
7573             # fails and consequently DBD::SQLite fails and now we are
7574             # processing CPAN::SQLite. Then we must have a "next" for
7575             # DBD::SQLite. How can we get it and how can we identify
7576             # all other cases we must identify?
7577
7578             my $do = $nmo->distribution;
7579             next NEED unless $do; # not on CPAN
7580           NOSAYER: for my $nosayer (
7581                                     "unwrapped",
7582                                     "writemakefile",
7583                                     "signature_verify",
7584                                     "make",
7585                                     "make_test",
7586                                     "install",
7587                                     "make_clean",
7588                                    ) {
7589                 if (
7590                     $do->{$nosayer}
7591                     &&(UNIVERSAL::can($do->{$nosayer},"failed") ?
7592                        $do->{$nosayer}->failed :
7593                        $do->{$nosayer} =~ /^NO/)
7594                    ) {
7595                     if ($nosayer eq "make_test"
7596                         &&
7597                         $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7598                        ) {
7599                         next NOSAYER;
7600                     }
7601                     $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7602                                             "'$need_module => $need_version' ".
7603                                             "for '$self->{ID}' failed when ".
7604                                             "processing '$do->{ID}' with ".
7605                                             "'$nosayer => $do->{$nosayer}'. Continuing, ".
7606                                             "but chances to succeed are limited.\n"
7607                                            );
7608                     next NEED;
7609                 }
7610             }
7611         }
7612         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7613         push @need, [$need_module,$needed_as];
7614     }
7615     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7616     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7617     @need;
7618 }
7619
7620 #-> sub CPAN::Distribution::read_yaml ;
7621 sub read_yaml {
7622     my($self) = @_;
7623     return $self->{yaml_content} if exists $self->{yaml_content};
7624     my $build_dir = $self->{build_dir};
7625     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7626     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7627     return unless -f $yaml;
7628     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7629     if ($@) {
7630         $CPAN::Frontend->mywarn("Could not read ".
7631                                 "'$yaml'. Falling back to other ".
7632                                 "methods to determine prerequisites\n");
7633         return $self->{yaml_content} = undef; # if we die, then we
7634                                               # cannot read YAML's own
7635                                               # META.yml
7636     }
7637     # not "authoritative"
7638     if (not exists $self->{yaml_content}{dynamic_config}
7639         or $self->{yaml_content}{dynamic_config}
7640        ) {
7641         $self->{yaml_content} = undef;
7642     }
7643     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7644         if $CPAN::DEBUG;
7645     return $self->{yaml_content};
7646 }
7647
7648 #-> sub CPAN::Distribution::prereq_pm ;
7649 sub prereq_pm {
7650     my($self) = @_;
7651     $self->{prereq_pm_detected} ||= 0;
7652     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7653     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7654     return unless $self->{writemakefile}  # no need to have succeeded
7655                                           # but we must have run it
7656         || $self->{modulebuild};
7657     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7658                 $self->{writemakefile}||"",
7659                 $self->{modulebuild}||"",
7660                ) if $CPAN::DEBUG;
7661     my($req,$breq);
7662     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7663         $req =  $yaml->{requires} || {};
7664         $breq =  $yaml->{build_requires} || {};
7665         undef $req unless ref $req eq "HASH" && %$req;
7666         if ($req) {
7667             if ($yaml->{generated_by} &&
7668                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7669                 my $eummv = do { local $^W = 0; $1+0; };
7670                 if ($eummv < 6.2501) {
7671                     # thanks to Slaven for digging that out: MM before
7672                     # that could be wrong because it could reflect a
7673                     # previous release
7674                     undef $req;
7675                 }
7676             }
7677             my $areq;
7678             my $do_replace;
7679             while (my($k,$v) = each %{$req||{}}) {
7680                 if ($v =~ /\d/) {
7681                     $areq->{$k} = $v;
7682                 } elsif ($k =~ /[A-Za-z]/ &&
7683                          $v =~ /[A-Za-z]/ &&
7684                          $CPAN::META->exists("Module",$v)
7685                         ) {
7686                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7687                                             "requires hash: $k => $v; I'll take both ".
7688                                             "key and value as a module name\n");
7689                     $CPAN::Frontend->mysleep(1);
7690                     $areq->{$k} = 0;
7691                     $areq->{$v} = 0;
7692                     $do_replace++;
7693                 }
7694             }
7695             $req = $areq if $do_replace;
7696         }
7697     }
7698     unless ($req || $breq) {
7699         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7700         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7701         my $fh;
7702         if (-f $makefile
7703             and
7704             $fh = FileHandle->new("<$makefile\0")) {
7705             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7706             local($/) = "\n";
7707             while (<$fh>) {
7708                 last if /MakeMaker post_initialize section/;
7709                 my($p) = m{^[\#]
7710                            \s+PREREQ_PM\s+=>\s+(.+)
7711                        }x;
7712                 next unless $p;
7713                 # warn "Found prereq expr[$p]";
7714
7715                 #  Regexp modified by A.Speer to remember actual version of file
7716                 #  PREREQ_PM hash key wants, then add to
7717                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7718                     # In case a prereq is mentioned twice, complain.
7719                     if ( defined $req->{$1} ) {
7720                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7721                             "last mention wins";
7722                     }
7723                     my($m,$n) = ($1,$2);
7724                     if ($n =~ /^q\[(.*?)\]$/) {
7725                         $n = $1;
7726                     }
7727                     $req->{$m} = $n;
7728                 }
7729                 last;
7730             }
7731         }
7732     }
7733     unless ($req || $breq) {
7734         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7735         my $buildfile = File::Spec->catfile($build_dir,"Build");
7736         if (-f $buildfile) {
7737             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7738             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7739             if (-f $build_prereqs) {
7740                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7741                 my $content = do { local *FH;
7742                                    open FH, $build_prereqs
7743                                        or $CPAN::Frontend->mydie("Could not open ".
7744                                                                  "'$build_prereqs': $!");
7745                                    local $/;
7746                                    <FH>;
7747                                };
7748                 my $bphash = eval $content;
7749                 if ($@) {
7750                 } else {
7751                     $req  = $bphash->{requires} || +{};
7752                     $breq = $bphash->{build_requires} || +{};
7753                 }
7754             }
7755         }
7756     }
7757     if (-f "Build.PL"
7758         && ! -f "Makefile.PL"
7759         && ! exists $req->{"Module::Build"}
7760         && ! $CPAN::META->has_inst("Module::Build")) {
7761         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7762                                 "undeclared prerequisite.\n".
7763                                 "  Adding it now as such.\n"
7764                                );
7765         $CPAN::Frontend->mysleep(5);
7766         $req->{"Module::Build"} = 0;
7767         delete $self->{writemakefile};
7768     }
7769     if ($req || $breq) {
7770         $self->{prereq_pm_detected}++;
7771         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7772     }
7773 }
7774
7775 #-> sub CPAN::Distribution::test ;
7776 sub test {
7777     my($self) = @_;
7778     if (my $goto = $self->prefs->{goto}) {
7779         return $self->goto($goto);
7780     }
7781     $self->make;
7782     if ($CPAN::Signal){
7783       delete $self->{force_update};
7784       return;
7785     }
7786     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7787     if ($self->{notest}) {
7788         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7789         return 1;
7790     }
7791
7792     my $make = $self->{modulebuild} ? "Build" : "make";
7793
7794     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7795                            ? $ENV{PERL5LIB}
7796                            : ($ENV{PERLLIB} || "");
7797
7798     $CPAN::META->set_perl5lib;
7799     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7800
7801     $CPAN::Frontend->myprint("Running $make test\n");
7802
7803 #    if (my @prereq = $self->unsat_prereq){
7804 #        if ( $CPAN::DEBUG ) {
7805 #            require Data::Dumper;
7806 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7807 #        }
7808 #        unless ($prereq[0][0] eq "perl") {
7809 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7810 #        }
7811 #    }
7812
7813   EXCUSE: {
7814         my @e;
7815         unless (exists $self->{make} or exists $self->{later}) {
7816             push @e,
7817                 "Make had some problems, won't test";
7818         }
7819
7820         exists $self->{make} and
7821             (
7822              UNIVERSAL::can($self->{make},"failed") ?
7823              $self->{make}->failed :
7824              $self->{make} =~ /^NO/
7825             ) and push @e, "Can't test without successful make";
7826
7827         $self->{badtestcnt} ||= 0;
7828         if ($self->{badtestcnt} > 0) {
7829             require Data::Dumper;
7830             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7831             push @e, "Won't repeat unsuccessful test during this command";
7832         }
7833
7834         exists $self->{later} and length($self->{later}) and
7835             push @e, $self->{later};
7836
7837         if (exists $self->{build_dir}) {
7838             if ($CPAN::META->{is_tested}{$self->{build_dir}}
7839                 &&
7840                 exists $self->{make_test}
7841                 &&
7842                 !(
7843                   UNIVERSAL::can($self->{make_test},"failed") ?
7844                   $self->{make_test}->failed :
7845                   $self->{make_test} =~ /^NO/
7846                  )
7847                ) {
7848                 push @e, "Has already been tested successfully";
7849             }
7850         } elsif (!@e) {
7851             push @e, "Has no own directory";
7852         }
7853         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7854         unless (chdir $self->{build_dir}) {
7855             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
7856         }
7857         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7858     }
7859     $self->debug("Changed directory to $self->{build_dir}")
7860         if $CPAN::DEBUG;
7861
7862     if ($^O eq 'MacOS') {
7863         Mac::BuildTools::make_test($self);
7864         return;
7865     }
7866
7867     if ($self->{modulebuild}) {
7868         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
7869         if (CPAN::Version->vlt($v,2.62)) {
7870             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
7871   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
7872             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
7873             return;
7874         }
7875     }
7876
7877     my $system;
7878     if (my $commandline = $self->prefs->{test}{commandline}) {
7879         $system = $commandline;
7880         $ENV{PERL} = $^X;
7881     } elsif ($self->{modulebuild}) {
7882         $system = sprintf "%s test", $self->_build_command();
7883     } else {
7884         $system = join " ", $self->_make_command(), "test";
7885     }
7886     my $make_test_arg = $self->make_x_arg("test");
7887     $system = sprintf("%s%s",
7888                       $system,
7889                       $make_test_arg ? " $make_test_arg" : "",
7890                      );
7891     my($tests_ok);
7892     my %env;
7893     while (my($k,$v) = each %ENV) {
7894         next unless defined $v;
7895         $env{$k} = $v;
7896     }
7897     local %ENV = %env;
7898     if (my $env = $self->prefs->{test}{env}) {
7899         for my $e (keys %$env) {
7900             $ENV{$e} = $env->{$e};
7901         }
7902     }
7903     my $expect_model = $self->_prefs_with_expect("test");
7904     my $want_expect = 0;
7905     if ( $expect_model && @{$expect_model->{talk}} ) {
7906         my $can_expect = $CPAN::META->has_inst("Expect");
7907         if ($can_expect) {
7908             $want_expect = 1;
7909         } else {
7910             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7911                                     "testing without\n");
7912         }
7913     }
7914     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
7915                                                        q{test_report});
7916     my $want_report;
7917     if ($test_report) {
7918         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
7919         if ($can_report) {
7920             $want_report = 1;
7921         } else {
7922             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
7923                                     "testing without\n");
7924         }
7925     }
7926     my $ready_to_report = $want_report;
7927     if ($ready_to_report
7928         && (
7929             substr($self->id,-1,1) eq "."
7930             ||
7931             $self->author->id eq "LOCAL"
7932            )
7933        ) {
7934         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7935                                 "for local directories\n");
7936         $ready_to_report = 0;
7937     }
7938     if ($ready_to_report
7939         &&
7940         $self->prefs->{patches}
7941         &&
7942         @{$self->prefs->{patches}}
7943         &&
7944         $self->{patched}
7945        ) {
7946         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
7947                                 "when the source has been patched\n");
7948         $ready_to_report = 0;
7949     }
7950     if ($want_expect) {
7951         if ($ready_to_report) {
7952             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
7953                                     "not supported when distroprefs specify ".
7954                                     "an interactive test\n");
7955         }
7956         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
7957     } elsif ( $ready_to_report ) {
7958         $tests_ok = CPAN::Reporter::test($self, $system);
7959     } else {
7960         $tests_ok = system($system) == 0;
7961     }
7962     $self->introduce_myself;
7963     if ( $tests_ok ) {
7964         {
7965             my @prereq;
7966
7967             # local $CPAN::DEBUG = 16; # Distribution
7968             for my $m (keys %{$self->{sponsored_mods}}) {
7969                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
7970                 # XXX we need available_version which reflects
7971                 # $ENV{PERL5LIB} so that already tested but not yet
7972                 # installed modules are counted.
7973                 my $available_version = $m_obj->available_version;
7974                 my $available_file = $m_obj->available_file;
7975                 if ($available_version &&
7976                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
7977                    ) {
7978                     CPAN->debug("m[$m] good enough available_version[$available_version]")
7979                         if $CPAN::DEBUG;
7980                 } elsif ($available_file
7981                          && (
7982                              !$self->{prereq_pm}{$m}
7983                              ||
7984                              $self->{prereq_pm}{$m} == 0
7985                             )
7986                         ) {
7987                     # lex Class::Accessor::Chained::Fast which has no $VERSION
7988                     CPAN->debug("m[$m] have available_file[$available_file]")
7989                         if $CPAN::DEBUG;
7990                 } else {
7991                     push @prereq, $m;
7992                 }
7993             }
7994             if (@prereq){
7995                 my $cnt = @prereq;
7996                 my $which = join ",", @prereq;
7997                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
7998                     "$cnt dependencies missing ($which)";
7999                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8000                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8001                 $self->store_persistent_state;
8002                 return;
8003             }
8004         }
8005
8006         $CPAN::Frontend->myprint("  $system -- OK\n");
8007         $self->{make_test} = CPAN::Distrostatus->new("YES");
8008         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8009         # probably impossible to need the next line because badtestcnt
8010         # has a lifespan of one command
8011         delete $self->{badtestcnt};
8012     } else {
8013         $self->{make_test} = CPAN::Distrostatus->new("NO");
8014         $self->{badtestcnt}++;
8015         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8016     }
8017     $self->store_persistent_state;
8018 }
8019
8020 sub _prefs_with_expect {
8021     my($self,$where) = @_;
8022     return unless my $prefs = $self->prefs;
8023     return unless my $where_prefs = $prefs->{$where};
8024     if ($where_prefs->{expect}) {
8025         return {
8026                 mode => "deterministic",
8027                 timeout => 15,
8028                 talk => $where_prefs->{expect},
8029                };
8030     } elsif ($where_prefs->{"eexpect"}) {
8031         return $where_prefs->{"eexpect"};
8032     }
8033     return;
8034 }
8035
8036 #-> sub CPAN::Distribution::clean ;
8037 sub clean {
8038     my($self) = @_;
8039     my $make = $self->{modulebuild} ? "Build" : "make";
8040     $CPAN::Frontend->myprint("Running $make clean\n");
8041     unless (exists $self->{archived}) {
8042         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8043                                 "/untarred, nothing done\n");
8044         return 1;
8045     }
8046     unless (exists $self->{build_dir}) {
8047         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8048         return 1;
8049     }
8050   EXCUSE: {
8051         my @e;
8052         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8053             push @e, "make clean already called once";
8054         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8055     }
8056     chdir $self->{build_dir} or
8057         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8058     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8059
8060     if ($^O eq 'MacOS') {
8061         Mac::BuildTools::make_clean($self);
8062         return;
8063     }
8064
8065     my $system;
8066     if ($self->{modulebuild}) {
8067         unless (-f "Build") {
8068             my $cwd = CPAN::anycwd();
8069             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8070                                     " in cwd[$cwd]. Danger, Will Robinson!");
8071             $CPAN::Frontend->mysleep(5);
8072         }
8073         $system = sprintf "%s clean", $self->_build_command();
8074     } else {
8075         $system  = join " ", $self->_make_command(), "clean";
8076     }
8077     my $system_ok = system($system) == 0;
8078     $self->introduce_myself;
8079     if ( $system_ok ) {
8080       $CPAN::Frontend->myprint("  $system -- OK\n");
8081
8082       # $self->force;
8083
8084       # Jost Krieger pointed out that this "force" was wrong because
8085       # it has the effect that the next "install" on this distribution
8086       # will untar everything again. Instead we should bring the
8087       # object's state back to where it is after untarring.
8088
8089       for my $k (qw(
8090                     force_update
8091                     install
8092                     writemakefile
8093                     make
8094                     make_test
8095                    )) {
8096           delete $self->{$k};
8097       }
8098       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8099
8100     } else {
8101       # Hmmm, what to do if make clean failed?
8102
8103       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8104       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8105
8106       # 2006-02-27: seems silly to me to force a make now
8107       # $self->force("make"); # so that this directory won't be used again
8108
8109     }
8110     $self->store_persistent_state;
8111 }
8112
8113 #-> sub CPAN::Distribution::goto ;
8114 sub goto {
8115     my($self,$goto) = @_;
8116     $goto = $self->normalize($goto);
8117
8118     # inject into the queue
8119
8120     CPAN::Queue->delete($self->id);
8121     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8122
8123     # and run where we left off
8124
8125     my($method) = (caller(1))[3];
8126     CPAN->instance("CPAN::Distribution",$goto)->$method;
8127     CPAN::Queue->delete_first($goto);
8128 }
8129
8130 #-> sub CPAN::Distribution::install ;
8131 sub install {
8132     my($self) = @_;
8133     if (my $goto = $self->prefs->{goto}) {
8134         return $self->goto($goto);
8135     }
8136     $DB::single=1;
8137     unless ($self->{badtestcnt}) {
8138         $self->test;
8139     }
8140     if ($CPAN::Signal){
8141       delete $self->{force_update};
8142       return;
8143     }
8144     my $make = $self->{modulebuild} ? "Build" : "make";
8145     $CPAN::Frontend->myprint("Running $make install\n");
8146   EXCUSE: {
8147         my @e;
8148         unless (exists $self->{make} or exists $self->{later}) {
8149             push @e,
8150                 "Make had some problems, won't install";
8151         }
8152
8153         exists $self->{make} and
8154             (
8155              UNIVERSAL::can($self->{make},"failed") ?
8156              $self->{make}->failed :
8157              $self->{make} =~ /^NO/
8158             ) and
8159                 push @e, "Make had returned bad status, install seems impossible";
8160
8161         if (exists $self->{build_dir}) {
8162         } elsif (!@e) {
8163             push @e, "Has no own directory";
8164         }
8165
8166         if (exists $self->{make_test} and
8167             (
8168              UNIVERSAL::can($self->{make_test},"failed") ?
8169              $self->{make_test}->failed :
8170              $self->{make_test} =~ /^NO/
8171             )){
8172             if ($self->{force_update}) {
8173                 $self->{make_test}->text("FAILED but failure ignored because ".
8174                                          "'force' in effect");
8175             } else {
8176                 push @e, "make test had returned bad status, ".
8177                     "won't install without force"
8178             }
8179         }
8180         if (exists $self->{install}) {
8181             if (UNIVERSAL::can($self->{install},"text") ?
8182                 $self->{install}->text eq "YES" :
8183                 $self->{install} =~ /^YES/
8184                ) {
8185                 push @e, "Already done";
8186             } else {
8187                 # comment in Todo on 2006-02-11; maybe retry?
8188                 push @e, "Already tried without success";
8189             }
8190         }
8191
8192         exists $self->{later} and length($self->{later}) and
8193             push @e, $self->{later};
8194
8195         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8196         unless (chdir $self->{build_dir}) {
8197             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8198         }
8199         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8200     }
8201     $self->debug("Changed directory to $self->{build_dir}")
8202         if $CPAN::DEBUG;
8203
8204     if ($^O eq 'MacOS') {
8205         Mac::BuildTools::make_install($self);
8206         return;
8207     }
8208
8209     my $system;
8210     if (my $commandline = $self->prefs->{install}{commandline}) {
8211         $system = $commandline;
8212         $ENV{PERL} = $^X;
8213     } elsif ($self->{modulebuild}) {
8214         my($mbuild_install_build_command) =
8215             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8216                 $CPAN::Config->{mbuild_install_build_command} ?
8217                     $CPAN::Config->{mbuild_install_build_command} :
8218                         $self->_build_command();
8219         $system = sprintf("%s install %s",
8220                           $mbuild_install_build_command,
8221                           $CPAN::Config->{mbuild_install_arg},
8222                          );
8223     } else {
8224         my($make_install_make_command) =
8225             CPAN::HandleConfig->prefs_lookup($self,
8226                                              q{make_install_make_command})
8227                   || $self->_make_command();
8228         $system = sprintf("%s install %s",
8229                           $make_install_make_command,
8230                           $CPAN::Config->{make_install_arg},
8231                          );
8232     }
8233
8234     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8235     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8236                                                 q{build_requires_install_policy});
8237     $brip ||="ask/yes";
8238     my $id = $self->id;
8239     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8240     my $want_install = "yes";
8241     if ($reqtype eq "b") {
8242         if ($brip eq "no") {
8243             $want_install = "no";
8244         } elsif ($brip =~ m|^ask/(.+)|) {
8245             my $default = $1;
8246             $default = "yes" unless $default =~ /^(y|n)/i;
8247             $want_install =
8248                 CPAN::Shell::colorable_makemaker_prompt
8249                       ("$id is just needed temporarily during building or testing. ".
8250                        "Do you want to install it permanently? (Y/n)",
8251                        $default);
8252         }
8253     }
8254     unless ($want_install =~ /^y/i) {
8255         my $is_only = "is only 'build_requires'";
8256         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8257         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8258         delete $self->{force_update};
8259         return;
8260     }
8261     my($pipe) = FileHandle->new("$system $stderr |");
8262     my($makeout) = "";
8263     while (<$pipe>){
8264         print $_; # intentionally NOT use Frontend->myprint because it
8265                   # looks irritating when we markup in color what we
8266                   # just pass through from an external program
8267         $makeout .= $_;
8268     }
8269     $pipe->close;
8270     my $close_ok = $? == 0;
8271     $self->introduce_myself;
8272     if ( $close_ok ) {
8273         $CPAN::Frontend->myprint("  $system -- OK\n");
8274         $CPAN::META->is_installed($self->{build_dir});
8275         $self->{install} = CPAN::Distrostatus->new("YES");
8276     } else {
8277         $self->{install} = CPAN::Distrostatus->new("NO");
8278         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8279         my $mimc =
8280             CPAN::HandleConfig->prefs_lookup($self,
8281                                              q{make_install_make_command});
8282         if (
8283             $makeout =~ /permission/s
8284             && $> > 0
8285             && (
8286                 ! $mimc
8287                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8288                                                               q{make}))
8289                )
8290            ) {
8291             $CPAN::Frontend->myprint(
8292                                      qq{----\n}.
8293                                      qq{  You may have to su }.
8294                                      qq{to root to install the package\n}.
8295                                      qq{  (Or you may want to run something like\n}.
8296                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8297                                      qq{  to raise your permissions.}
8298                                     );
8299         }
8300     }
8301     delete $self->{force_update};
8302     # $DB::single = 1;
8303     $self->store_persistent_state;
8304 }
8305
8306 sub introduce_myself {
8307     my($self) = @_;
8308     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8309 }
8310
8311 #-> sub CPAN::Distribution::dir ;
8312 sub dir {
8313     shift->{build_dir};
8314 }
8315
8316 #-> sub CPAN::Distribution::perldoc ;
8317 sub perldoc {
8318     my($self) = @_;
8319
8320     my($dist) = $self->id;
8321     my $package = $self->called_for;
8322
8323     $self->_display_url( $CPAN::Defaultdocs . $package );
8324 }
8325
8326 #-> sub CPAN::Distribution::_check_binary ;
8327 sub _check_binary {
8328     my ($dist,$shell,$binary) = @_;
8329     my ($pid,$out);
8330
8331     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8332       if $CPAN::DEBUG;
8333
8334     if ($CPAN::META->has_inst("File::Which")) {
8335         return File::Which::which($binary);
8336     } else {
8337         local *README;
8338         $pid = open README, "which $binary|"
8339             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8340         return unless $pid;
8341         while (<README>) {
8342             $out .= $_;
8343         }
8344         close README
8345             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8346                 and return;
8347     }
8348
8349     $CPAN::Frontend->myprint(qq{   + $out \n})
8350       if $CPAN::DEBUG && $out;
8351
8352     return $out;
8353 }
8354
8355 #-> sub CPAN::Distribution::_display_url ;
8356 sub _display_url {
8357     my($self,$url) = @_;
8358     my($res,$saved_file,$pid,$out);
8359
8360     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8361       if $CPAN::DEBUG;
8362
8363     # should we define it in the config instead?
8364     my $html_converter = "html2text";
8365
8366     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8367     my $web_browser_out = $web_browser
8368       ? CPAN::Distribution->_check_binary($self,$web_browser)
8369         : undef;
8370
8371     if ($web_browser_out) {
8372         # web browser found, run the action
8373         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8374         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8375           if $CPAN::DEBUG;
8376         $CPAN::Frontend->myprint(qq{
8377 Displaying URL
8378   $url
8379 with browser $browser
8380 });
8381         $CPAN::Frontend->mysleep(1);
8382         system("$browser $url");
8383         if ($saved_file) { 1 while unlink($saved_file) }
8384     } else {
8385         # web browser not found, let's try text only
8386         my $html_converter_out =
8387           CPAN::Distribution->_check_binary($self,$html_converter);
8388         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8389
8390         if ($html_converter_out ) {
8391             # html2text found, run it
8392             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8393             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8394                 unless defined($saved_file);
8395
8396             local *README;
8397             $pid = open README, "$html_converter $saved_file |"
8398               or $CPAN::Frontend->mydie(qq{
8399 Could not fork '$html_converter $saved_file': $!});
8400             my($fh,$filename);
8401             if ($CPAN::META->has_inst("File::Temp")) {
8402                 $fh = File::Temp->new(
8403                                       template => 'cpan_htmlconvert_XXXX',
8404                                       suffix => '.txt',
8405                                       unlink => 0,
8406                                      );
8407                 $filename = $fh->filename;
8408             } else {
8409                 $filename = "cpan_htmlconvert_$$.txt";
8410                 $fh = FileHandle->new();
8411                 open $fh, ">$filename" or die;
8412             }
8413             while (<README>) {
8414                 $fh->print($_);
8415             }
8416             close README or
8417                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8418             my $tmpin = $fh->filename;
8419             $CPAN::Frontend->myprint(sprintf(qq{
8420 Run '%s %s' and
8421 saved output to %s\n},
8422                                              $html_converter,
8423                                              $saved_file,
8424                                              $tmpin,
8425                                             )) if $CPAN::DEBUG;
8426             close $fh;
8427             local *FH;
8428             open FH, $tmpin
8429                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8430             my $fh_pager = FileHandle->new;
8431             local($SIG{PIPE}) = "IGNORE";
8432             my $pager = $CPAN::Config->{'pager'} || "cat";
8433             $fh_pager->open("|$pager")
8434                 or $CPAN::Frontend->mydie(qq{
8435 Could not open pager '$pager': $!});
8436             $CPAN::Frontend->myprint(qq{
8437 Displaying URL
8438   $url
8439 with pager "$pager"
8440 });
8441             $CPAN::Frontend->mysleep(1);
8442             $fh_pager->print(<FH>);
8443             $fh_pager->close;
8444         } else {
8445             # coldn't find the web browser or html converter
8446             $CPAN::Frontend->myprint(qq{
8447 You need to install lynx or $html_converter to use this feature.});
8448         }
8449     }
8450 }
8451
8452 #-> sub CPAN::Distribution::_getsave_url ;
8453 sub _getsave_url {
8454     my($dist, $shell, $url) = @_;
8455
8456     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8457       if $CPAN::DEBUG;
8458
8459     my($fh,$filename);
8460     if ($CPAN::META->has_inst("File::Temp")) {
8461         $fh = File::Temp->new(
8462                               template => "cpan_getsave_url_XXXX",
8463                               suffix => ".html",
8464                               unlink => 0,
8465                              );
8466         $filename = $fh->filename;
8467     } else {
8468         $fh = FileHandle->new;
8469         $filename = "cpan_getsave_url_$$.html";
8470     }
8471     my $tmpin = $filename;
8472     if ($CPAN::META->has_usable('LWP')) {
8473         $CPAN::Frontend->myprint("Fetching with LWP:
8474   $url
8475 ");
8476         my $Ua;
8477         CPAN::LWP::UserAgent->config;
8478         eval { $Ua = CPAN::LWP::UserAgent->new; };
8479         if ($@) {
8480             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8481             return;
8482         } else {
8483             my($var);
8484             $Ua->proxy('http', $var)
8485                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8486             $Ua->no_proxy($var)
8487                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8488         }
8489
8490         my $req = HTTP::Request->new(GET => $url);
8491         $req->header('Accept' => 'text/html');
8492         my $res = $Ua->request($req);
8493         if ($res->is_success) {
8494             $CPAN::Frontend->myprint(" + request successful.\n")
8495                 if $CPAN::DEBUG;
8496             print $fh $res->content;
8497             close $fh;
8498             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8499                 if $CPAN::DEBUG;
8500             return $tmpin;
8501         } else {
8502             $CPAN::Frontend->myprint(sprintf(
8503                                              "LWP failed with code[%s], message[%s]\n",
8504                                              $res->code,
8505                                              $res->message,
8506                                             ));
8507             return;
8508         }
8509     } else {
8510         $CPAN::Frontend->mywarn("  LWP not available\n");
8511         return;
8512     }
8513 }
8514
8515 # sub CPAN::Distribution::_build_command
8516 sub _build_command {
8517     my($self) = @_;
8518     if ($^O eq "MSWin32") { # special code needed at least up to
8519                             # Module::Build 0.2611 and 0.2706; a fix
8520                             # in M:B has been promised 2006-01-30
8521         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8522         return "$perl ./Build";
8523     }
8524     return "./Build";
8525 }
8526
8527 package CPAN::Bundle;
8528 use strict;
8529
8530 sub look {
8531     my $self = shift;
8532     $CPAN::Frontend->myprint($self->as_string);
8533 }
8534
8535 sub undelay {
8536     my $self = shift;
8537     delete $self->{later};
8538     for my $c ( $self->contains ) {
8539         my $obj = CPAN::Shell->expandany($c) or next;
8540         $obj->undelay;
8541     }
8542 }
8543
8544 # mark as dirty/clean
8545 #-> sub CPAN::Bundle::color_cmd_tmps ;
8546 sub color_cmd_tmps {
8547     my($self) = shift;
8548     my($depth) = shift || 0;
8549     my($color) = shift || 0;
8550     my($ancestors) = shift || [];
8551     # a module needs to recurse to its cpan_file, a distribution needs
8552     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8553
8554     return if exists $self->{incommandcolor}
8555         && $color==1
8556         && $self->{incommandcolor}==$color;
8557     if ($depth>=$CPAN::MAX_RECURSION){
8558         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8559     }
8560     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8561
8562     for my $c ( $self->contains ) {
8563         my $obj = CPAN::Shell->expandany($c) or next;
8564         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8565         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8566     }
8567     # never reached code?
8568     #if ($color==0) {
8569       #delete $self->{badtestcnt};
8570     #}
8571     $self->{incommandcolor} = $color;
8572 }
8573
8574 #-> sub CPAN::Bundle::as_string ;
8575 sub as_string {
8576     my($self) = @_;
8577     $self->contains;
8578     # following line must be "=", not "||=" because we have a moving target
8579     $self->{INST_VERSION} = $self->inst_version;
8580     return $self->SUPER::as_string;
8581 }
8582
8583 #-> sub CPAN::Bundle::contains ;
8584 sub contains {
8585     my($self) = @_;
8586     my($inst_file) = $self->inst_file || "";
8587     my($id) = $self->id;
8588     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8589     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8590         undef $inst_file;
8591     }
8592     unless ($inst_file) {
8593         # Try to get at it in the cpan directory
8594         $self->debug("no inst_file") if $CPAN::DEBUG;
8595         my $cpan_file;
8596         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8597               $cpan_file = $self->cpan_file;
8598         if ($cpan_file eq "N/A") {
8599             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8600   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8601         }
8602         my $dist = $CPAN::META->instance('CPAN::Distribution',
8603                                          $self->cpan_file);
8604         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8605         $dist->get;
8606         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8607         my($todir) = $CPAN::Config->{'cpan_home'};
8608         my(@me,$from,$to,$me);
8609         @me = split /::/, $self->id;
8610         $me[-1] .= ".pm";
8611         $me = File::Spec->catfile(@me);
8612         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8613         $to = File::Spec->catfile($todir,$me);
8614         File::Path::mkpath(File::Basename::dirname($to));
8615         File::Copy::copy($from, $to)
8616               or Carp::confess("Couldn't copy $from to $to: $!");
8617         $inst_file = $to;
8618     }
8619     my @result;
8620     my $fh = FileHandle->new;
8621     local $/ = "\n";
8622     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8623     my $in_cont = 0;
8624     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8625     while (<$fh>) {
8626         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8627             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8628         next unless $in_cont;
8629         next if /^=/;
8630         s/\#.*//;
8631         next if /^\s+$/;
8632         chomp;
8633         push @result, (split " ", $_, 2)[0];
8634     }
8635     close $fh;
8636     delete $self->{STATUS};
8637     $self->{CONTAINS} = \@result;
8638     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8639     unless (@result) {
8640         $CPAN::Frontend->mywarn(qq{
8641 The bundle file "$inst_file" may be a broken
8642 bundlefile. It seems not to contain any bundle definition.
8643 Please check the file and if it is bogus, please delete it.
8644 Sorry for the inconvenience.
8645 });
8646     }
8647     @result;
8648 }
8649
8650 #-> sub CPAN::Bundle::find_bundle_file
8651 # $where is in local format, $what is in unix format
8652 sub find_bundle_file {
8653     my($self,$where,$what) = @_;
8654     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8655 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8656 ###    my $bu = File::Spec->catfile($where,$what);
8657 ###    return $bu if -f $bu;
8658     my $manifest = File::Spec->catfile($where,"MANIFEST");
8659     unless (-f $manifest) {
8660         require ExtUtils::Manifest;
8661         my $cwd = CPAN::anycwd();
8662         $self->safe_chdir($where);
8663         ExtUtils::Manifest::mkmanifest();
8664         $self->safe_chdir($cwd);
8665     }
8666     my $fh = FileHandle->new($manifest)
8667         or Carp::croak("Couldn't open $manifest: $!");
8668     local($/) = "\n";
8669     my $bundle_filename = $what;
8670     $bundle_filename =~ s|Bundle.*/||;
8671     my $bundle_unixpath;
8672     while (<$fh>) {
8673         next if /^\s*\#/;
8674         my($file) = /(\S+)/;
8675         if ($file =~ m|\Q$what\E$|) {
8676             $bundle_unixpath = $file;
8677             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8678             last;
8679         }
8680         # retry if she managed to have no Bundle directory
8681         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8682     }
8683     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8684         if $bundle_unixpath;
8685     Carp::croak("Couldn't find a Bundle file in $where");
8686 }
8687
8688 # needs to work quite differently from Module::inst_file because of
8689 # cpan_home/Bundle/ directory and the possibility that we have
8690 # shadowing effect. As it makes no sense to take the first in @INC for
8691 # Bundles, we parse them all for $VERSION and take the newest.
8692
8693 #-> sub CPAN::Bundle::inst_file ;
8694 sub inst_file {
8695     my($self) = @_;
8696     my($inst_file);
8697     my(@me);
8698     @me = split /::/, $self->id;
8699     $me[-1] .= ".pm";
8700     my($incdir,$bestv);
8701     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8702         my $bfile = File::Spec->catfile($incdir, @me);
8703         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8704         next unless -f $bfile;
8705         my $foundv = MM->parse_version($bfile);
8706         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8707             $self->{INST_FILE} = $bfile;
8708             $self->{INST_VERSION} = $bestv = $foundv;
8709         }
8710     }
8711     $self->{INST_FILE};
8712 }
8713
8714 #-> sub CPAN::Bundle::inst_version ;
8715 sub inst_version {
8716     my($self) = @_;
8717     $self->inst_file; # finds INST_VERSION as side effect
8718     $self->{INST_VERSION};
8719 }
8720
8721 #-> sub CPAN::Bundle::rematein ;
8722 sub rematein {
8723     my($self,$meth) = @_;
8724     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8725     my($id) = $self->id;
8726     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8727         unless $self->inst_file || $self->cpan_file;
8728     my($s,%fail);
8729     for $s ($self->contains) {
8730         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8731             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8732         if ($type eq 'CPAN::Distribution') {
8733             $CPAN::Frontend->mywarn(qq{
8734 The Bundle }.$self->id.qq{ contains
8735 explicitly a file '$s'.
8736 Going to $meth that.
8737 });
8738             $CPAN::Frontend->mysleep(5);
8739         }
8740         # possibly noisy action:
8741         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8742         my $obj = $CPAN::META->instance($type,$s);
8743         $obj->{reqtype} = $self->{reqtype};
8744         $obj->$meth();
8745     }
8746 }
8747
8748 # If a bundle contains another that contains an xs_file we have here,
8749 # we just don't bother I suppose
8750 #-> sub CPAN::Bundle::xs_file
8751 sub xs_file {
8752     return 0;
8753 }
8754
8755 #-> sub CPAN::Bundle::force ;
8756 sub fforce   { shift->rematein('fforce',@_); }
8757 #-> sub CPAN::Bundle::force ;
8758 sub force   { shift->rematein('force',@_); }
8759 #-> sub CPAN::Bundle::notest ;
8760 sub notest  { shift->rematein('notest',@_); }
8761 #-> sub CPAN::Bundle::get ;
8762 sub get     { shift->rematein('get',@_); }
8763 #-> sub CPAN::Bundle::make ;
8764 sub make    { shift->rematein('make',@_); }
8765 #-> sub CPAN::Bundle::test ;
8766 sub test    {
8767     my $self = shift;
8768     # $self->{badtestcnt} ||= 0;
8769     $self->rematein('test',@_);
8770 }
8771 #-> sub CPAN::Bundle::install ;
8772 sub install {
8773   my $self = shift;
8774   $self->rematein('install',@_);
8775 }
8776 #-> sub CPAN::Bundle::clean ;
8777 sub clean   { shift->rematein('clean',@_); }
8778
8779 #-> sub CPAN::Bundle::uptodate ;
8780 sub uptodate {
8781     my($self) = @_;
8782     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8783     my $c;
8784     foreach $c ($self->contains) {
8785         my $obj = CPAN::Shell->expandany($c);
8786         return 0 unless $obj->uptodate;
8787     }
8788     return 1;
8789 }
8790
8791 #-> sub CPAN::Bundle::readme ;
8792 sub readme  {
8793     my($self) = @_;
8794     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8795 No File found for bundle } . $self->id . qq{\n}), return;
8796     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8797     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8798 }
8799
8800 package CPAN::Module;
8801 use strict;
8802
8803 # Accessors
8804 # sub CPAN::Module::userid
8805 sub userid {
8806     my $self = shift;
8807     my $ro = $self->ro;
8808     return unless $ro;
8809     return $ro->{userid} || $ro->{CPAN_USERID};
8810 }
8811 # sub CPAN::Module::description
8812 sub description {
8813     my $self = shift;
8814     my $ro = $self->ro or return "";
8815     $ro->{description}
8816 }
8817
8818 sub distribution {
8819     my($self) = @_;
8820     CPAN::Shell->expand("Distribution",$self->cpan_file);
8821 }
8822
8823 # sub CPAN::Module::undelay
8824 sub undelay {
8825     my $self = shift;
8826     delete $self->{later};
8827     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8828         $dist->undelay;
8829     }
8830 }
8831
8832 # mark as dirty/clean
8833 #-> sub CPAN::Module::color_cmd_tmps ;
8834 sub color_cmd_tmps {
8835     my($self) = shift;
8836     my($depth) = shift || 0;
8837     my($color) = shift || 0;
8838     my($ancestors) = shift || [];
8839     # a module needs to recurse to its cpan_file
8840
8841     return if exists $self->{incommandcolor}
8842         && $color==1
8843         && $self->{incommandcolor}==$color;
8844     return if $color==0 && !$self->{incommandcolor};
8845     if ($color>=1) {
8846         if ( $self->uptodate ) {
8847             $self->{incommandcolor} = $color;
8848             return;
8849         } elsif (my $have_version = $self->available_version) {
8850             # maybe what we have is good enough
8851             if (@$ancestors) {
8852                 my $who_asked_for_me = $ancestors->[-1];
8853                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
8854                 if (0) {
8855                 } elsif ($obj->isa("CPAN::Bundle")) {
8856                     # bundles cannot specify a minimum version
8857                     return;
8858                 } elsif ($obj->isa("CPAN::Distribution")) {
8859                     if (my $prereq_pm = $obj->prereq_pm) {
8860                         for my $k (keys %$prereq_pm) {
8861                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
8862                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
8863                                     $self->{incommandcolor} = $color;
8864                                     return;
8865                                 }
8866                             }
8867                         }
8868                     }
8869                 }
8870             }
8871         }
8872     } else {
8873         $self->{incommandcolor} = $color; # set me before recursion,
8874                                           # so we can break it
8875     }
8876     if ($depth>=$CPAN::MAX_RECURSION){
8877         $CPAN::Frontend->mydie(CPAN::Exception::RecursiveDependency->new($ancestors));
8878     }
8879     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8880
8881     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8882         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8883     }
8884     # unreached code?
8885     # if ($color==0) {
8886     #    delete $self->{badtestcnt};
8887     # }
8888     $self->{incommandcolor} = $color;
8889 }
8890
8891 #-> sub CPAN::Module::as_glimpse ;
8892 sub as_glimpse {
8893     my($self) = @_;
8894     my(@m);
8895     my $class = ref($self);
8896     $class =~ s/^CPAN:://;
8897     my $color_on = "";
8898     my $color_off = "";
8899     if (
8900         $CPAN::Shell::COLOR_REGISTERED
8901         &&
8902         $CPAN::META->has_inst("Term::ANSIColor")
8903         &&
8904         $self->description
8905        ) {
8906         $color_on = Term::ANSIColor::color("green");
8907         $color_off = Term::ANSIColor::color("reset");
8908     }
8909     my $uptodateness = " ";
8910     if ($class eq "Bundle") {
8911     } elsif ($self->uptodate) {
8912         $uptodateness = "=";
8913     } elsif ($self->inst_version) {
8914         $uptodateness = "<";
8915     }
8916     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
8917                      $class,
8918                      $uptodateness,
8919                      $color_on,
8920                      $self->id,
8921                      $color_off,
8922                      ($self->distribution ?
8923                       $self->distribution->pretty_id :
8924                       $self->cpan_userid
8925                      ),
8926                     );
8927     join "", @m;
8928 }
8929
8930 #-> sub CPAN::Module::dslip_status
8931 sub dslip_status {
8932     my($self) = @_;
8933     my($stat);
8934     # development status
8935     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
8936                                               pre-alpha alpha beta released
8937                                               mature standard,;
8938     # support level
8939     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
8940                                               developer comp.lang.perl.*
8941                                               none abandoned,;
8942     # language
8943     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
8944     # interface
8945     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
8946                                               references+ties
8947                                               object-oriented pragma
8948                                               hybrid none,;
8949     # public licence
8950     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
8951                                               GPL LGPL
8952                                               BSD Artistic
8953                                               open-source
8954                                               distribution_allowed
8955                                               restricted_distribution
8956                                               no_licence,;
8957     for my $x (qw(d s l i p)) {
8958         $stat->{$x}{' '} = 'unknown';
8959         $stat->{$x}{'?'} = 'unknown';
8960     }
8961     my $ro = $self->ro;
8962     return +{} unless $ro && $ro->{statd};
8963     return {
8964             D  => $ro->{statd},
8965             S  => $ro->{stats},
8966             L  => $ro->{statl},
8967             I  => $ro->{stati},
8968             P  => $ro->{statp},
8969             DV => $stat->{D}{$ro->{statd}},
8970             SV => $stat->{S}{$ro->{stats}},
8971             LV => $stat->{L}{$ro->{statl}},
8972             IV => $stat->{I}{$ro->{stati}},
8973             PV => $stat->{P}{$ro->{statp}},
8974            };
8975 }
8976
8977 #-> sub CPAN::Module::as_string ;
8978 sub as_string {
8979     my($self) = @_;
8980     my(@m);
8981     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
8982     my $class = ref($self);
8983     $class =~ s/^CPAN:://;
8984     local($^W) = 0;
8985     push @m, $class, " id = $self->{ID}\n";
8986     my $sprintf = "    %-12s %s\n";
8987     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
8988         if $self->description;
8989     my $sprintf2 = "    %-12s %s (%s)\n";
8990     my($userid);
8991     $userid = $self->userid;
8992     if ( $userid ){
8993         my $author;
8994         if ($author = CPAN::Shell->expand('Author',$userid)) {
8995           my $email = "";
8996           my $m; # old perls
8997           if ($m = $author->email) {
8998             $email = " <$m>";
8999           }
9000           push @m, sprintf(
9001                            $sprintf2,
9002                            'CPAN_USERID',
9003                            $userid,
9004                            $author->fullname . $email
9005                           );
9006         }
9007     }
9008     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9009         if $self->cpan_version;
9010     if (my $cpan_file = $self->cpan_file){
9011         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9012         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9013             my $upload_date = $dist->upload_date;
9014             if ($upload_date) {
9015                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9016             }
9017         }
9018     }
9019     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9020     my $dslip = $self->dslip_status;
9021     push @m, sprintf(
9022                      $sprintf3,
9023                      'DSLIP_STATUS',
9024                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9025                     ) if $dslip->{D};
9026     my $local_file = $self->inst_file;
9027     unless ($self->{MANPAGE}) {
9028         my $manpage;
9029         if ($local_file) {
9030             $manpage = $self->manpage_headline($local_file);
9031         } else {
9032             # If we have already untarred it, we should look there
9033             my $dist = $CPAN::META->instance('CPAN::Distribution',
9034                                              $self->cpan_file);
9035             # warn "dist[$dist]";
9036             # mff=manifest file; mfh=manifest handle
9037             my($mff,$mfh);
9038             if (
9039                 $dist->{build_dir}
9040                 and
9041                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9042                 and
9043                 $mfh = FileHandle->new($mff)
9044                ) {
9045                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9046                 my $lfre = $self->id; # local file RE
9047                 $lfre =~ s/::/./g;
9048                 $lfre .= "\\.pm\$";
9049                 my($lfl); # local file file
9050                 local $/ = "\n";
9051                 my(@mflines) = <$mfh>;
9052                 for (@mflines) {
9053                     s/^\s+//;
9054                     s/\s.*//s;
9055                 }
9056                 while (length($lfre)>5 and !$lfl) {
9057                     ($lfl) = grep /$lfre/, @mflines;
9058                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9059                     $lfre =~ s/.+?\.//;
9060                 }
9061                 $lfl =~ s/\s.*//; # remove comments
9062                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9063                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9064                 # warn "lfl_abs[$lfl_abs]";
9065                 if (-f $lfl_abs) {
9066                     $manpage = $self->manpage_headline($lfl_abs);
9067                 }
9068             }
9069         }
9070         $self->{MANPAGE} = $manpage if $manpage;
9071     }
9072     my($item);
9073     for $item (qw/MANPAGE/) {
9074         push @m, sprintf($sprintf, $item, $self->{$item})
9075             if exists $self->{$item};
9076     }
9077     for $item (qw/CONTAINS/) {
9078         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9079             if exists $self->{$item} && @{$self->{$item}};
9080     }
9081     push @m, sprintf($sprintf, 'INST_FILE',
9082                      $local_file || "(not installed)");
9083     push @m, sprintf($sprintf, 'INST_VERSION',
9084                      $self->inst_version) if $local_file;
9085     join "", @m, "\n";
9086 }
9087
9088 sub manpage_headline {
9089   my($self,$local_file) = @_;
9090   my(@local_file) = $local_file;
9091   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9092   push @local_file, $local_file;
9093   my(@result,$locf);
9094   for $locf (@local_file) {
9095     next unless -f $locf;
9096     my $fh = FileHandle->new($locf)
9097         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9098     my $inpod = 0;
9099     local $/ = "\n";
9100     while (<$fh>) {
9101       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9102           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9103       next unless $inpod;
9104       next if /^=/;
9105       next if /^\s+$/;
9106       chomp;
9107       push @result, $_;
9108     }
9109     close $fh;
9110     last if @result;
9111   }
9112   for (@result) {
9113       s/^\s+//;
9114       s/\s+$//;
9115   }
9116   join " ", @result;
9117 }
9118
9119 #-> sub CPAN::Module::cpan_file ;
9120 # Note: also inherited by CPAN::Bundle
9121 sub cpan_file {
9122     my $self = shift;
9123     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9124     unless ($self->ro) {
9125         CPAN::Index->reload;
9126     }
9127     my $ro = $self->ro;
9128     if ($ro && defined $ro->{CPAN_FILE}){
9129         return $ro->{CPAN_FILE};
9130     } else {
9131         my $userid = $self->userid;
9132         if ( $userid ) {
9133             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9134                 my $author = $CPAN::META->instance("CPAN::Author",
9135                                                    $userid);
9136                 my $fullname = $author->fullname;
9137                 my $email = $author->email;
9138                 unless (defined $fullname && defined $email) {
9139                     return sprintf("Contact Author %s",
9140                                    $userid,
9141                                   );
9142                 }
9143                 return "Contact Author $fullname <$email>";
9144             } else {
9145                 return "Contact Author $userid (Email address not available)";
9146             }
9147         } else {
9148             return "N/A";
9149         }
9150     }
9151 }
9152
9153 #-> sub CPAN::Module::cpan_version ;
9154 sub cpan_version {
9155     my $self = shift;
9156
9157     my $ro = $self->ro;
9158     unless ($ro) {
9159         # Can happen with modules that are not on CPAN
9160         $ro = {};
9161     }
9162     $ro->{CPAN_VERSION} = 'undef'
9163         unless defined $ro->{CPAN_VERSION};
9164     $ro->{CPAN_VERSION};
9165 }
9166
9167 #-> sub CPAN::Module::force ;
9168 sub force {
9169     my($self) = @_;
9170     $self->{force_update} = 1;
9171 }
9172
9173 #-> sub CPAN::Module::fforce ;
9174 sub fforce {
9175     my($self) = @_;
9176     $self->{force_update} = 2;
9177 }
9178
9179 sub notest {
9180     my($self) = @_;
9181     # warn "XDEBUG: set notest for Module";
9182     $self->{'notest'}++;
9183 }
9184
9185 #-> sub CPAN::Module::rematein ;
9186 sub rematein {
9187     my($self,$meth) = @_;
9188     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9189                                      $meth,
9190                                      $self->id));
9191     my $cpan_file = $self->cpan_file;
9192     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9193       $CPAN::Frontend->mywarn(sprintf qq{
9194   The module %s isn\'t available on CPAN.
9195
9196   Either the module has not yet been uploaded to CPAN, or it is
9197   temporary unavailable. Please contact the author to find out
9198   more about the status. Try 'i %s'.
9199 },
9200                               $self->id,
9201                               $self->id,
9202                              );
9203       return;
9204     }
9205     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9206     $pack->called_for($self->id);
9207     if (exists $self->{force_update}){
9208         if ($self->{force_update} == 2) {
9209             $pack->fforce($meth);
9210         } else {
9211             $pack->force($meth);
9212         }
9213     }
9214     $pack->notest($meth) if exists $self->{'notest'};
9215
9216     $pack->{reqtype} ||= "";
9217     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9218                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9219         if ($pack->{reqtype}) {
9220             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9221                 $pack->{reqtype} = $self->{reqtype};
9222                 if (
9223                     exists $pack->{install}
9224                     &&
9225                     (
9226                      UNIVERSAL::can($pack->{install},"failed") ?
9227                      $pack->{install}->failed :
9228                      $pack->{install} =~ /^NO/
9229                     )
9230                    ) {
9231                     delete $pack->{install};
9232                     $CPAN::Frontend->mywarn
9233                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9234                 }
9235             }
9236         } else {
9237             $pack->{reqtype} = $self->{reqtype};
9238         }
9239
9240     eval {
9241         $pack->$meth();
9242     };
9243     my $err = $@;
9244     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9245     $pack->unnotest if $pack->can("unnotest") && exists $self->{'notest'};
9246     delete $self->{force_update};
9247     delete $self->{'notest'};
9248     if ($err) {
9249         die $err;
9250     }
9251 }
9252
9253 #-> sub CPAN::Module::perldoc ;
9254 sub perldoc { shift->rematein('perldoc') }
9255 #-> sub CPAN::Module::readme ;
9256 sub readme  { shift->rematein('readme') }
9257 #-> sub CPAN::Module::look ;
9258 sub look    { shift->rematein('look') }
9259 #-> sub CPAN::Module::cvs_import ;
9260 sub cvs_import { shift->rematein('cvs_import') }
9261 #-> sub CPAN::Module::get ;
9262 sub get     { shift->rematein('get',@_) }
9263 #-> sub CPAN::Module::make ;
9264 sub make    { shift->rematein('make') }
9265 #-> sub CPAN::Module::test ;
9266 sub test   {
9267     my $self = shift;
9268     # $self->{badtestcnt} ||= 0;
9269     $self->rematein('test',@_);
9270 }
9271 #-> sub CPAN::Module::uptodate ;
9272 sub uptodate {
9273     my($self) = @_;
9274     local($_); # protect against a bug in MakeMaker 6.17
9275     my($latest) = $self->cpan_version;
9276     $latest ||= 0;
9277     my($inst_file) = $self->inst_file;
9278     my($have) = 0;
9279     if (defined $inst_file) {
9280         $have = $self->inst_version;
9281     }
9282     local($^W)=0;
9283     if ($inst_file
9284         &&
9285         ! CPAN::Version->vgt($latest, $have)
9286        ) {
9287         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9288                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9289         return 1;
9290     }
9291     return;
9292 }
9293 #-> sub CPAN::Module::install ;
9294 sub install {
9295     my($self) = @_;
9296     my($doit) = 0;
9297     if ($self->uptodate
9298         &&
9299         not exists $self->{force_update}
9300        ) {
9301         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9302                                          $self->id,
9303                                          $self->inst_version,
9304                                         ));
9305     } else {
9306         $doit = 1;
9307     }
9308     my $ro = $self->ro;
9309     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9310         $CPAN::Frontend->mywarn(qq{
9311 \n\n\n     ***WARNING***
9312      The module $self->{ID} has no active maintainer.\n\n\n
9313 });
9314         $CPAN::Frontend->mysleep(5);
9315     }
9316     $self->rematein('install') if $doit;
9317 }
9318 #-> sub CPAN::Module::clean ;
9319 sub clean  { shift->rematein('clean') }
9320
9321 #-> sub CPAN::Module::inst_file ;
9322 sub inst_file {
9323     my($self) = @_;
9324     $self->_file_in_path([@INC]);
9325 }
9326
9327 #-> sub CPAN::Module::available_file ;
9328 sub available_file {
9329     my($self) = @_;
9330     my $sep = $Config::Config{path_sep};
9331     my $perllib = $ENV{PERL5LIB};
9332     $perllib = $ENV{PERLLIB} unless defined $perllib;
9333     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9334     $self->_file_in_path([@perllib,@INC]);
9335 }
9336
9337 #-> sub CPAN::Module::file_in_path ;
9338 sub _file_in_path {
9339     my($self,$path) = @_;
9340     my($dir,@packpath);
9341     @packpath = split /::/, $self->{ID};
9342     $packpath[-1] .= ".pm";
9343     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9344         unshift @packpath, "Term", "ReadLine"; # historical reasons
9345     }
9346     foreach $dir (@$path) {
9347         my $pmfile = File::Spec->catfile($dir,@packpath);
9348         if (-f $pmfile){
9349             return $pmfile;
9350         }
9351     }
9352     return;
9353 }
9354
9355 #-> sub CPAN::Module::xs_file ;
9356 sub xs_file {
9357     my($self) = @_;
9358     my($dir,@packpath);
9359     @packpath = split /::/, $self->{ID};
9360     push @packpath, $packpath[-1];
9361     $packpath[-1] .= "." . $Config::Config{'dlext'};
9362     foreach $dir (@INC) {
9363         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9364         if (-f $xsfile){
9365             return $xsfile;
9366         }
9367     }
9368     return;
9369 }
9370
9371 #-> sub CPAN::Module::inst_version ;
9372 sub inst_version {
9373     my($self) = @_;
9374     my $parsefile = $self->inst_file or return;
9375     my $have = $self->parse_version($parsefile);
9376     $have;
9377 }
9378
9379 #-> sub CPAN::Module::inst_version ;
9380 sub available_version {
9381     my($self) = @_;
9382     my $parsefile = $self->available_file or return;
9383     my $have = $self->parse_version($parsefile);
9384     $have;
9385 }
9386
9387 #-> sub CPAN::Module::parse_version ;
9388 sub parse_version {
9389     my($self,$parsefile) = @_;
9390     my $have = MM->parse_version($parsefile);
9391     $have = "undef" unless defined $have && length $have;
9392     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9393     $have =~ s/ $//; # trailing whitespace happens all the time
9394
9395     $have = CPAN::Version->readable($have);
9396
9397     $have =~ s/\s*//g; # stringify to float around floating point issues
9398     $have; # no stringify needed, \s* above matches always
9399 }
9400
9401 package CPAN;
9402 use strict;
9403
9404 1;
9405
9406
9407 __END__
9408
9409 =head1 NAME
9410
9411 CPAN - query, download and build perl modules from CPAN sites
9412
9413 =head1 SYNOPSIS
9414
9415 Interactive mode:
9416
9417   perl -MCPAN -e shell
9418
9419 --or--
9420
9421   cpan
9422
9423 Basic commands:
9424
9425   # Modules:
9426
9427   cpan> install Acme::Meta                       # in the shell
9428
9429   CPAN::Shell->install("Acme::Meta");            # in perl
9430
9431   # Distributions:
9432
9433   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9434
9435   CPAN::Shell->
9436     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9437
9438   # module objects:
9439
9440   $mo = CPAN::Shell->expandany($mod);
9441   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9442
9443   # distribution objects:
9444
9445   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9446   $do = CPAN::Shell->expandany($distro);         # same thing
9447   $do = CPAN::Shell->expand("Distribution",
9448                             $distro);            # same thing
9449
9450 =head1 DESCRIPTION
9451
9452 The CPAN module automates or at least simplifies the make and install
9453 of perl modules and extensions. It includes some primitive searching
9454 capabilities and knows how to use Net::FTP or LWP or some external
9455 download clients to fetch the distributions from the net.
9456
9457 These are fetched from one or more of the mirrored CPAN (Comprehensive
9458 Perl Archive Network) sites and unpacked in a dedicated directory.
9459
9460 The CPAN module also supports the concept of named and versioned
9461 I<bundles> of modules. Bundles simplify the handling of sets of
9462 related modules. See Bundles below.
9463
9464 The package contains a session manager and a cache manager. The
9465 session manager keeps track of what has been fetched, built and
9466 installed in the current session. The cache manager keeps track of the
9467 disk space occupied by the make processes and deletes excess space
9468 according to a simple FIFO mechanism.
9469
9470 All methods provided are accessible in a programmer style and in an
9471 interactive shell style.
9472
9473 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9474
9475 The interactive mode is entered by running
9476
9477     perl -MCPAN -e shell
9478
9479 or
9480
9481     cpan
9482
9483 which puts you into a readline interface. If C<Term::ReadKey> and
9484 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9485 it supports both history and command completion.
9486
9487 Once you are on the command line, type C<h> to get a one page help
9488 screen and the rest should be self-explanatory.
9489
9490 The function call C<shell> takes two optional arguments, one is the
9491 prompt, the second is the default initial command line (the latter
9492 only works if a real ReadLine interface module is installed).
9493
9494 The most common uses of the interactive modes are
9495
9496 =over 2
9497
9498 =item Searching for authors, bundles, distribution files and modules
9499
9500 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9501 for each of the four categories and another, C<i> for any of the
9502 mentioned four. Each of the four entities is implemented as a class
9503 with slightly differing methods for displaying an object.
9504
9505 Arguments you pass to these commands are either strings exactly matching
9506 the identification string of an object or regular expressions that are
9507 then matched case-insensitively against various attributes of the
9508 objects. The parser recognizes a regular expression only if you
9509 enclose it between two slashes.
9510
9511 The principle is that the number of found objects influences how an
9512 item is displayed. If the search finds one item, the result is
9513 displayed with the rather verbose method C<as_string>, but if we find
9514 more than one, we display each object with the terse method
9515 C<as_glimpse>.
9516
9517 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9518
9519 These commands take any number of arguments and investigate what is
9520 necessary to perform the action. If the argument is a distribution
9521 file name (recognized by embedded slashes), it is processed. If it is
9522 a module, CPAN determines the distribution file in which this module
9523 is included and processes that, following any dependencies named in
9524 the module's META.yml or Makefile.PL (this behavior is controlled by
9525 the configuration parameter C<prerequisites_policy>.)
9526
9527 C<get> downloads a distribution file and untars or unzips it, C<make>
9528 builds it, C<test> runs the test suite, and C<install> installs it.
9529
9530 Any C<make> or C<test> are run unconditionally. An
9531
9532   install <distribution_file>
9533
9534 also is run unconditionally. But for
9535
9536   install <module>
9537
9538 CPAN checks if an install is actually needed for it and prints
9539 I<module up to date> in the case that the distribution file containing
9540 the module doesn't need to be updated.
9541
9542 CPAN also keeps track of what it has done within the current session
9543 and doesn't try to build a package a second time regardless if it
9544 succeeded or not. It does not repeat a test run if the test
9545 has been run successfully before. Same for install runs.
9546
9547 The C<force> pragma may precede another command (currently: C<get>,
9548 C<make>, C<test>, or C<install>) and executes the command from scratch
9549 and tries to continue in case of some errors. See the section below on
9550 the C<force> and the C<fforce> pragma.
9551
9552 The C<notest> pragma may be used to skip the test part in the build
9553 process.
9554
9555 Example:
9556
9557     cpan> notest install Tk
9558
9559 A C<clean> command results in a
9560
9561   make clean
9562
9563 being executed within the distribution file's working directory.
9564
9565 =item C<readme>, C<perldoc>, C<look> module or distribution
9566
9567 C<readme> displays the README file of the associated distribution.
9568 C<Look> gets and untars (if not yet done) the distribution file,
9569 changes to the appropriate directory and opens a subshell process in
9570 that directory. C<perldoc> displays the pod documentation of the
9571 module in html or plain text format.
9572
9573 =item C<ls> author
9574
9575 =item C<ls> globbing_expression
9576
9577 The first form lists all distribution files in and below an author's
9578 CPAN directory as they are stored in the CHECKUMS files distributed on
9579 CPAN. The listing goes recursive into all subdirectories.
9580
9581 The second form allows to limit or expand the output with shell
9582 globbing as in the following examples:
9583
9584           ls JV/make*
9585           ls GSAR/*make*
9586           ls */*make*
9587
9588 The last example is very slow and outputs extra progress indicators
9589 that break the alignment of the result.
9590
9591 Note that globbing only lists directories explicitly asked for, for
9592 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9593 regarded as a bug and may be changed in future versions.
9594
9595 =item C<failed>
9596
9597 The C<failed> command reports all distributions that failed on one of
9598 C<make>, C<test> or C<install> for some reason in the currently
9599 running shell session.
9600
9601 =item Persistence between sessions
9602
9603 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9604 the internal state of all modules is written to disk after each step.
9605 The files contain a signature of the currently running perl version
9606 for later perusal.
9607
9608 If the configurations variable C<build_dir_reuse> is set to a true
9609 value, then CPAN.pm reads the collected YAML files. If the stored
9610 signature matches the currently running perl the stored state is
9611 loaded into memory such that effectively persistence between sessions
9612 is established.
9613
9614 =item The C<force> and the C<fforce> pragma
9615
9616 To speed things up in complex installation scenarios, CPAN.pm keeps
9617 track of what it has already done and refuses to do some things a
9618 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9619 A C<test> is only repeated if the previous test was unsuccessful. The
9620 diagnostic message when CPAN.pm refuses to do something a second time
9621 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9622 something similar. Another situation where CPAN refuses to act is an
9623 C<install> if the according C<test> was not successful.
9624
9625 In all these cases, the user can override the goatish behaviour by
9626 prepending the command with the word force, for example:
9627
9628   cpan> force get Foo
9629   cpan> force make AUTHOR/Bar-3.14.tar.gz
9630   cpan> force test Baz
9631   cpan> force install Acme::Meta
9632
9633 Each I<forced> command is executed with the according part of its
9634 memory erased.
9635
9636 The C<fforce> pragma is a variant that emulates a C<force get> which
9637 erases the entire memory followed by the action specified, effectively
9638 restarting the whole get/make/test/install procedure from scratch.
9639
9640 =item Lockfile
9641
9642 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9643 Batch jobs can run without a lockfile and do not disturb each other.
9644
9645 The shell offers to run in I<degraded mode> when another process is
9646 holding the lockfile. This is an experimental feature that is not yet
9647 tested very well. This second shell then does not write the history
9648 file, does not use the metadata file and has a different prompt.
9649
9650 =item Signals
9651
9652 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9653 in the cpan-shell it is intended that you can press C<^C> anytime and
9654 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9655 to clean up and leave the shell loop. You can emulate the effect of a
9656 SIGTERM by sending two consecutive SIGINTs, which usually means by
9657 pressing C<^C> twice.
9658
9659 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9660 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9661 Build.PL> subprocess.
9662
9663 =back
9664
9665 =head2 CPAN::Shell
9666
9667 The commands that are available in the shell interface are methods in
9668 the package CPAN::Shell. If you enter the shell command, all your
9669 input is split by the Text::ParseWords::shellwords() routine which
9670 acts like most shells do. The first word is being interpreted as the
9671 method to be called and the rest of the words are treated as arguments
9672 to this method. Continuation lines are supported if a line ends with a
9673 literal backslash.
9674
9675 =head2 autobundle
9676
9677 C<autobundle> writes a bundle file into the
9678 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9679 a list of all modules that are both available from CPAN and currently
9680 installed within @INC. The name of the bundle file is based on the
9681 current date and a counter.
9682
9683 =head2 hosts
9684
9685 Note: this feature is still in alpha state and may change in future
9686 versions of CPAN.pm
9687
9688 This commands provides a statistical overview over recent download
9689 activities. The data for this is collected in the YAML file
9690 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9691 configured or YAML not installed, then no stats are provided.
9692
9693 =head2 mkmyconfig
9694
9695 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9696 directory so that you can save your own preferences instead of the
9697 system wide ones.
9698
9699 =head2 recompile
9700
9701 recompile() is a very special command in that it takes no argument and
9702 runs the make/test/install cycle with brute force over all installed
9703 dynamically loadable extensions (aka XS modules) with 'force' in
9704 effect. The primary purpose of this command is to finish a network
9705 installation. Imagine, you have a common source tree for two different
9706 architectures. You decide to do a completely independent fresh
9707 installation. You start on one architecture with the help of a Bundle
9708 file produced earlier. CPAN installs the whole Bundle for you, but
9709 when you try to repeat the job on the second architecture, CPAN
9710 responds with a C<"Foo up to date"> message for all modules. So you
9711 invoke CPAN's recompile on the second architecture and you're done.
9712
9713 Another popular use for C<recompile> is to act as a rescue in case your
9714 perl breaks binary compatibility. If one of the modules that CPAN uses
9715 is in turn depending on binary compatibility (so you cannot run CPAN
9716 commands), then you should try the CPAN::Nox module for recovery.
9717
9718 =head2 report Bundle|Distribution|Module
9719
9720 The C<report> command temporarily turns on the C<test_report> config
9721 variable, then runs the C<force test> command with the given
9722 arguments. The C<force> pragma is used to re-run the tests and repeat
9723 every step that might have failed before.
9724
9725 =head2 upgrade [Module|/Regex/]...
9726
9727 The C<upgrade> command first runs an C<r> command with the given
9728 arguments and then installs the newest versions of all modules that
9729 were listed by that.
9730
9731 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9732
9733 Although it may be considered internal, the class hierarchy does matter
9734 for both users and programmer. CPAN.pm deals with above mentioned four
9735 classes, and all those classes share a set of methods. A classical
9736 single polymorphism is in effect. A metaclass object registers all
9737 objects of all kinds and indexes them with a string. The strings
9738 referencing objects have a separated namespace (well, not completely
9739 separated):
9740
9741          Namespace                         Class
9742
9743    words containing a "/" (slash)      Distribution
9744     words starting with Bundle::          Bundle
9745           everything else            Module or Author
9746
9747 Modules know their associated Distribution objects. They always refer
9748 to the most recent official release. Developers may mark their releases
9749 as unstable development versions (by inserting an underbar into the
9750 module version number which will also be reflected in the distribution
9751 name when you run 'make dist'), so the really hottest and newest
9752 distribution is not always the default.  If a module Foo circulates
9753 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9754 way to install version 1.23 by saying
9755
9756     install Foo
9757
9758 This would install the complete distribution file (say
9759 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9760 like to install version 1.23_90, you need to know where the
9761 distribution file resides on CPAN relative to the authors/id/
9762 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9763 so you would have to say
9764
9765     install BAR/Foo-1.23_90.tar.gz
9766
9767 The first example will be driven by an object of the class
9768 CPAN::Module, the second by an object of class CPAN::Distribution.
9769
9770 =head2 Integrating local directories
9771
9772 Note: this feature is still in alpha state and may change in future
9773 versions of CPAN.pm
9774
9775 Distribution objects are normally distributions from the CPAN, but
9776 there is a slightly degenerate case for Distribution objects, too, of
9777 projects held on the local disk. These distribution objects have the
9778 same name as the local directory and end with a dot. A dot by itself
9779 is also allowed for the current directory at the time CPAN.pm was
9780 used. All actions such as C<make>, C<test>, and C<install> are applied
9781 directly to that directory. This gives the command C<cpan .> an
9782 interesting touch: while the normal mantra of installing a CPAN module
9783 without CPAN.pm is one of
9784
9785     perl Makefile.PL                 perl Build.PL
9786            ( go and get prerequisites )
9787     make                             ./Build
9788     make test                        ./Build test
9789     make install                     ./Build install
9790
9791 the command C<cpan .> does all of this at once. It figures out which
9792 of the two mantras is appropriate, fetches and installs all
9793 prerequisites, cares for them recursively and finally finishes the
9794 installation of the module in the current directory, be it a CPAN
9795 module or not.
9796
9797 The typical usage case is for private modules or working copies of
9798 projects from remote repositories on the local disk.
9799
9800 =head1 CONFIGURATION
9801
9802 When the CPAN module is used for the first time, a configuration
9803 dialog tries to determine a couple of site specific options. The
9804 result of the dialog is stored in a hash reference C< $CPAN::Config >
9805 in a file CPAN/Config.pm.
9806
9807 The default values defined in the CPAN/Config.pm file can be
9808 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9809 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9810 added to the search path of the CPAN module before the use() or
9811 require() statements. The mkmyconfig command writes this file for you.
9812
9813 The C<o conf> command has various bells and whistles:
9814
9815 =over
9816
9817 =item completion support
9818
9819 If you have a ReadLine module installed, you can hit TAB at any point
9820 of the commandline and C<o conf> will offer you completion for the
9821 built-in subcommands and/or config variable names.
9822
9823 =item displaying some help: o conf help
9824
9825 Displays a short help
9826
9827 =item displaying current values: o conf [KEY]
9828
9829 Displays the current value(s) for this config variable. Without KEY
9830 displays all subcommands and config variables.
9831
9832 Example:
9833
9834   o conf shell
9835
9836 =item changing of scalar values: o conf KEY VALUE
9837
9838 Sets the config variable KEY to VALUE. The empty string can be
9839 specified as usual in shells, with C<''> or C<"">
9840
9841 Example:
9842
9843   o conf wget /usr/bin/wget
9844
9845 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
9846
9847 If a config variable name ends with C<list>, it is a list. C<o conf
9848 KEY shift> removes the first element of the list, C<o conf KEY pop>
9849 removes the last element of the list. C<o conf KEYS unshift LIST>
9850 prepends a list of values to the list, C<o conf KEYS push LIST>
9851 appends a list of valued to the list.
9852
9853 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
9854 splice command.
9855
9856 Finally, any other list of arguments is taken as a new list value for
9857 the KEY variable discarding the previous value.
9858
9859 Examples:
9860
9861   o conf urllist unshift http://cpan.dev.local/CPAN
9862   o conf urllist splice 3 1
9863   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
9864
9865 =item reverting to saved: o conf defaults
9866
9867 Reverts all config variables to the state in the saved config file.
9868
9869 =item saving the config: o conf commit
9870
9871 Saves all config variables to the current config file (CPAN/Config.pm
9872 or CPAN/MyConfig.pm that was loaded at start).
9873
9874 =back
9875
9876 The configuration dialog can be started any time later again by
9877 issuing the command C< o conf init > in the CPAN shell. A subset of
9878 the configuration dialog can be run by issuing C<o conf init WORD>
9879 where WORD is any valid config variable or a regular expression.
9880
9881 =head2 Config Variables
9882
9883 Currently the following keys in the hash reference $CPAN::Config are
9884 defined:
9885
9886   applypatch         path to external prg
9887   auto_commit        commit all changes to config variables to disk
9888   build_cache        size of cache for directories to build modules
9889   build_dir          locally accessible directory to build modules
9890   build_dir_reuse    boolean if distros in build_dir are persistent
9891   build_requires_install_policy
9892                      to install or not to install when a module is
9893                      only needed for building. yes|no|ask/yes|ask/no
9894   bzip2              path to external prg
9895   cache_metadata     use serializer to cache metadata
9896   commands_quote     prefered character to use for quoting external
9897                      commands when running them. Defaults to double
9898                      quote on Windows, single tick everywhere else;
9899                      can be set to space to disable quoting
9900   check_sigs         if signatures should be verified
9901   colorize_debug     Term::ANSIColor attributes for debugging output
9902   colorize_output    boolean if Term::ANSIColor should colorize output
9903   colorize_print     Term::ANSIColor attributes for normal output
9904   colorize_warn      Term::ANSIColor attributes for warnings
9905   commandnumber_in_prompt
9906                      boolean if you want to see current command number
9907   cpan_home          local directory reserved for this package
9908   curl               path to external prg
9909   dontload_hash      DEPRECATED
9910   dontload_list      arrayref: modules in the list will not be
9911                      loaded by the CPAN::has_inst() routine
9912   ftp                path to external prg
9913   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
9914   ftp_proxy          proxy host for ftp requests
9915   getcwd             see below
9916   gpg                path to external prg
9917   gzip               location of external program gzip
9918   histfile           file to maintain history between sessions
9919   histsize           maximum number of lines to keep in histfile
9920   http_proxy         proxy host for http requests
9921   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
9922                      after this many seconds inactivity. Set to 0 to
9923                      never break.
9924   index_expire       after this many days refetch index files
9925   inhibit_startup_message
9926                      if true, does not print the startup message
9927   keep_source_where  directory in which to keep the source (if we do)
9928   lynx               path to external prg
9929   make               location of external make program
9930   make_arg           arguments that should always be passed to 'make'
9931   make_install_make_command
9932                      the make command for running 'make install', for
9933                      example 'sudo make'
9934   make_install_arg   same as make_arg for 'make install'
9935   makepl_arg         arguments passed to 'perl Makefile.PL'
9936   mbuild_arg         arguments passed to './Build'
9937   mbuild_install_arg arguments passed to './Build install'
9938   mbuild_install_build_command
9939                      command to use instead of './Build' when we are
9940                      in the install stage, for example 'sudo ./Build'
9941   mbuildpl_arg       arguments passed to 'perl Build.PL'
9942   ncftp              path to external prg
9943   ncftpget           path to external prg
9944   no_proxy           don't proxy to these hosts/domains (comma separated list)
9945   pager              location of external program more (or any pager)
9946   password           your password if you CPAN server wants one
9947   patch              path to external prg
9948   prefer_installer   legal values are MB and EUMM: if a module comes
9949                      with both a Makefile.PL and a Build.PL, use the
9950                      former (EUMM) or the latter (MB); if the module
9951                      comes with only one of the two, that one will be
9952                      used in any case
9953   prerequisites_policy
9954                      what to do if you are missing module prerequisites
9955                      ('follow' automatically, 'ask' me, or 'ignore')
9956   prefs_dir          local directory to store per-distro build options
9957   proxy_user         username for accessing an authenticating proxy
9958   proxy_pass         password for accessing an authenticating proxy
9959   randomize_urllist  add some randomness to the sequence of the urllist
9960   scan_cache         controls scanning of cache ('atstart' or 'never')
9961   shell              your favorite shell
9962   show_upload_date   boolean if commands should try to determine upload date
9963   tar                location of external program tar
9964   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
9965                      (and nonsense for characters outside latin range)
9966   term_ornaments     boolean to turn ReadLine ornamenting on/off
9967   test_report        email test reports (if CPAN::Reporter is installed)
9968   unzip              location of external program unzip
9969   urllist            arrayref to nearby CPAN sites (or equivalent locations)
9970   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
9971   username           your username if you CPAN server wants one
9972   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
9973   wget               path to external prg
9974   yaml_module        which module to use to read/write YAML files
9975
9976 You can set and query each of these options interactively in the cpan
9977 shell with the C<o conf> or the C<o conf init> command as specified below.
9978
9979 =over 2
9980
9981 =item C<o conf E<lt>scalar optionE<gt>>
9982
9983 prints the current value of the I<scalar option>
9984
9985 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
9986
9987 Sets the value of the I<scalar option> to I<value>
9988
9989 =item C<o conf E<lt>list optionE<gt>>
9990
9991 prints the current value of the I<list option> in MakeMaker's
9992 neatvalue format.
9993
9994 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
9995
9996 shifts or pops the array in the I<list option> variable
9997
9998 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
9999
10000 works like the corresponding perl commands.
10001
10002 =item interactive editing: o conf init [MATCH|LIST]
10003
10004 Runs an interactive configuration dialog for matching variables.
10005 Without argument runs the dialog over all supported config variables.
10006 To specify a MATCH the argument must be enclosed by slashes.
10007
10008 Examples:
10009
10010   o conf init ftp_passive ftp_proxy
10011   o conf init /color/
10012
10013 Note: this method of setting config variables often provides more
10014 explanation about the functioning of a variable than the manpage.
10015
10016 =back
10017
10018 =head2 CPAN::anycwd($path): Note on config variable getcwd
10019
10020 CPAN.pm changes the current working directory often and needs to
10021 determine its own current working directory. Per default it uses
10022 Cwd::cwd but if this doesn't work on your system for some reason,
10023 alternatives can be configured according to the following table:
10024
10025 =over 4
10026
10027 =item cwd
10028
10029 Calls Cwd::cwd
10030
10031 =item getcwd
10032
10033 Calls Cwd::getcwd
10034
10035 =item fastcwd
10036
10037 Calls Cwd::fastcwd
10038
10039 =item backtickcwd
10040
10041 Calls the external command cwd.
10042
10043 =back
10044
10045 =head2 Note on the format of the urllist parameter
10046
10047 urllist parameters are URLs according to RFC 1738. We do a little
10048 guessing if your URL is not compliant, but if you have problems with
10049 C<file> URLs, please try the correct format. Either:
10050
10051     file://localhost/whatever/ftp/pub/CPAN/
10052
10053 or
10054
10055     file:///home/ftp/pub/CPAN/
10056
10057 =head2 The urllist parameter has CD-ROM support
10058
10059 The C<urllist> parameter of the configuration table contains a list of
10060 URLs that are to be used for downloading. If the list contains any
10061 C<file> URLs, CPAN always tries to get files from there first. This
10062 feature is disabled for index files. So the recommendation for the
10063 owner of a CD-ROM with CPAN contents is: include your local, possibly
10064 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10065
10066   o conf urllist push file://localhost/CDROM/CPAN
10067
10068 CPAN.pm will then fetch the index files from one of the CPAN sites
10069 that come at the beginning of urllist. It will later check for each
10070 module if there is a local copy of the most recent version.
10071
10072 Another peculiarity of urllist is that the site that we could
10073 successfully fetch the last file from automatically gets a preference
10074 token and is tried as the first site for the next request. So if you
10075 add a new site at runtime it may happen that the previously preferred
10076 site will be tried another time. This means that if you want to disallow
10077 a site for the next transfer, it must be explicitly removed from
10078 urllist.
10079
10080 =head2 Maintaining the urllist parameter
10081
10082 If you have YAML.pm (or some other YAML module configured in
10083 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10084 about recent downloads. You can view the statistics with the C<hosts>
10085 command or inspect them directly by looking into the C<FTPstats.yml>
10086 file in your C<cpan_home> directory.
10087
10088 To get some interesting statistics it is recommended to set the
10089 C<randomize_urllist> parameter that introduces some amount of
10090 randomness into the URL selection.
10091
10092 =head2 The C<requires> and C<build_requires> dependency declarations
10093
10094 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10095 a distribution are treated differently depending on the config
10096 variable C<build_requires_install_policy>. By setting
10097 C<build_requires_install_policy> to C<no> such a module is not being
10098 installed. It is only built and tested and then kept in the list of
10099 tested but uninstalled modules. As such it is available during the
10100 build of the dependent module by integrating the path to the
10101 C<blib/arch> and C<blib/lib> directories in the environment variable
10102 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10103 both modules declared as C<requires> and those declared as
10104 C<build_requires> are treated alike. By setting to C<ask/yes> or
10105 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10106
10107 =head2 Configuration for individual distributions (I<Distroprefs>)
10108
10109 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10110 still considered beta quality)
10111
10112 Distributions on the CPAN usually behave according to what we call the
10113 CPAN mantra. Or since the event of Module::Build we should talk about
10114 two mantras:
10115
10116     perl Makefile.PL     perl Build.PL
10117     make                 ./Build
10118     make test            ./Build test
10119     make install         ./Build install
10120
10121 But some modules cannot be built with this mantra. They try to get
10122 some extra data from the user via the environment, extra arguments or
10123 interactively thus disturbing the installation of large bundles like
10124 Phalanx100 or modules with many dependencies like Plagger.
10125
10126 The distroprefs system of C<CPAN.pm> addresses this problem by
10127 allowing the user to specify extra informations and recipes in YAML
10128 files to either
10129
10130 =over
10131
10132 =item
10133
10134 pass additional arguments to one of the four commands,
10135
10136 =item
10137
10138 set environment variables
10139
10140 =item
10141
10142 instantiate an Expect object that reads from the console, waits for
10143 some regular expressions and enters some answers
10144
10145 =item
10146
10147 temporarily override assorted C<CPAN.pm> configuration variables
10148
10149 =item
10150
10151 disable the installation of an object altogether
10152
10153 =back
10154
10155 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10156 distribution in the C<distroprefs/> directory for examples.
10157
10158 =head2 Filenames
10159
10160 The YAML files themselves must have the C<.yml> extension, all other
10161 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10162 Storable> below). The containing directory can be specified in
10163 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10164 prefs_dir> in the CPAN shell to set and activate the distroprefs
10165 system.
10166
10167 Every YAML file may contain arbitrary documents according to the YAML
10168 specification and every single document is treated as an entity that
10169 can specify the treatment of a single distribution.
10170
10171 The names of the files can be picked freely, C<CPAN.pm> always reads
10172 all files (in alphabetical order) and takes the key C<match> (see
10173 below in I<Language Specs>) as a hashref containing match criteria
10174 that determine if the current distribution matches the YAML document
10175 or not.
10176
10177 =head2 Fallback Data::Dumper and Storable
10178
10179 If neither your configured C<yaml_module> nor YAML.pm is installed
10180 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10181 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10182 directory. These files are expected to contain one or more hashrefs.
10183 For Data::Dumper generated files, this is expected to be done with by
10184 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10185 with the command
10186
10187     ysh < somefile.yml > somefile.dd
10188
10189 For Storable files the rule is that they must be constructed such that
10190 C<Storable::retrieve(file)> returns an array reference and the array
10191 elements represent one distropref object each. The conversion from
10192 YAML would look like so:
10193
10194     perl -MYAML=LoadFile -MStorable=nstore -e '
10195         @y=LoadFile(shift);
10196         nstore(\@y, shift)' somefile.yml somefile.st
10197
10198 In bootstrapping situations it is usually sufficient to translate only
10199 a few YAML files to Data::Dumper for the crucial modules like
10200 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10201 over Data::Dumper, remember to pull out a Storable version that writes
10202 an older format than all the other Storable versions that will need to
10203 read them.
10204
10205 =head2 Blueprint
10206
10207 The following example contains all supported keywords and structures
10208 with the exception of C<eexpect> which can be used instead of
10209 C<expect>.
10210
10211   ---
10212   comment: "Demo"
10213   match:
10214     module: "Dancing::Queen"
10215     distribution: "^CHACHACHA/Dancing-"
10216     perl: "/usr/local/cariba-perl/bin/perl"
10217     perlconfig:
10218       archname: "freebsd"
10219   disabled: 1
10220   cpanconfig:
10221     make: gmake
10222   pl:
10223     args:
10224       - "--somearg=specialcase"
10225
10226     env: {}
10227
10228     expect:
10229       - "Which is your favorite fruit"
10230       - "apple\n"
10231
10232   make:
10233     args:
10234       - all
10235       - extra-all
10236
10237     env: {}
10238
10239     expect: []
10240
10241     commendline: "echo SKIPPING make"
10242
10243   test:
10244     args: []
10245
10246     env: {}
10247
10248     expect: []
10249
10250   install:
10251     args: []
10252
10253     env:
10254       WANT_TO_INSTALL: YES
10255
10256     expect:
10257       - "Do you really want to install"
10258       - "y\n"
10259
10260   patches:
10261     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10262
10263
10264 =head2 Language Specs
10265
10266 Every YAML document represents a single hash reference. The valid keys
10267 in this hash are as follows:
10268
10269 =over
10270
10271 =item comment [scalar]
10272
10273 A comment
10274
10275 =item cpanconfig [hash]
10276
10277 Temporarily override assorted C<CPAN.pm> configuration variables.
10278
10279 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10280 C<make>, C<make_install_make_command>, C<prefer_installer>,
10281 C<test_report>. Please report as a bug when you need another one
10282 supported.
10283
10284 =item disabled [boolean]
10285
10286 Specifies that this distribution shall not be processed at all.
10287
10288 =item goto [string]
10289
10290 The canonical name of a delegate distribution that shall be installed
10291 instead. Useful when a new version, although it tests OK itself,
10292 breaks something else or a developer release or a fork is already
10293 uploaded that is better than the last released version.
10294
10295 =item install [hash]
10296
10297 Processing instructions for the C<make install> or C<./Build install>
10298 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10299
10300 =item make [hash]
10301
10302 Processing instructions for the C<make> or C<./Build> phase of the
10303 CPAN mantra. See below under I<Processiong Instructions>.
10304
10305 =item match [hash]
10306
10307 A hashref with one or more of the keys C<distribution>, C<modules>,
10308 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10309 specific CPAN distribution or installation.
10310
10311 The corresponding values are interpreted as regular expressions. The
10312 C<distribution> related one will be matched against the canonical
10313 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10314
10315 The C<module> related one will be matched against I<all> modules
10316 contained in the distribution until one module matches.
10317
10318 The C<perl> related one will be matched against C<$^X>.
10319
10320 The value associated with C<perlconfig> is itself a hashref that is
10321 matched against corresponding values in the C<%Config::Config> hash
10322 living in the C< Config.pm > module.
10323
10324 If more than one restriction of C<module>, C<distribution>, and
10325 C<perl> is specified, the results of the separately computed match
10326 values must all match. If this is the case then the hashref
10327 represented by the YAML document is returned as the preference
10328 structure for the current distribution.
10329
10330 =item patches [array]
10331
10332 An array of patches on CPAN or on the local disk to be applied in
10333 order via the external patch program. If the value for the C<-p>
10334 parameter is C<0> or C<1> is determined by reading the patch
10335 beforehand.
10336
10337 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10338 knows about it B<and> a patch is written by the C<makepatch> program,
10339 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10340 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10341 distribution.
10342
10343 =item pl [hash]
10344
10345 Processing instructions for the C<perl Makefile.PL> or C<perl
10346 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10347 Instructions>.
10348
10349 =item test [hash]
10350
10351 Processing instructions for the C<make test> or C<./Build test> phase
10352 of the CPAN mantra. See below under I<Processiong Instructions>.
10353
10354 =back
10355
10356 =head2 Processing Instructions
10357
10358 =over
10359
10360 =item args [array]
10361
10362 Arguments to be added to the command line
10363
10364 =item commandline
10365
10366 A full commandline that will be executed as it stands by a system
10367 call. During the execution the environment variable PERL will is set
10368 to $^X. If C<commandline> is specified, the content of C<args> is not
10369 used.
10370
10371 =item eexpect [hash]
10372
10373 Extended C<expect>. This is a hash reference with three allowed keys,
10374 C<mode>, C<timeout>, and C<talk>.
10375
10376 C<mode> may have the values C<deterministic> for the case where all
10377 questions come in the order written down and C<anyorder> for the case
10378 where the questions may come in any order. The default mode is
10379 C<deterministic>.
10380
10381 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10382 OK. In the case of a C<mode=deterministic> the timeout denotes the
10383 timeout per question, in the case of C<mode=anyorder> it denotes the
10384 timeout per byte received from the stream or questions.
10385
10386 C<talk> is a reference to an array that contains alternating questions
10387 and answers. Questions are regular expressions and answers are literal
10388 strings. The Expect module will then watch the stream coming from the
10389 execution of the external program (C<perl Makefile.PL>, C<perl
10390 Build.PL>, C<make>, etc.).
10391
10392 In the case of C<mode=deterministic> the CPAN.pm will inject the
10393 according answer as soon as the stream matches the regular expression.
10394 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10395 soon as the timeout is reached for the next byte in the input stream.
10396 In the latter case it removes the according question/answer pair from
10397 the array, so if you want to answer the question C<Do you really want
10398 to do that> several times, then it must be included in the array at
10399 least as often as you want this answer to be given.
10400
10401 =item env [hash]
10402
10403 Environment variables to be set during the command
10404
10405 =item expect [array]
10406
10407 C<< expect: <array> >> is a short notation for
10408
10409   eexpect:
10410     mode: deterministic
10411     timeout: 15
10412     talk: <array>
10413
10414 =back
10415
10416 =head2 Schema verification with C<Kwalify>
10417
10418 If you have the C<Kwalify> module installed (which is part of the
10419 Bundle::CPANxxl), then all your distroprefs files are checked for
10420 syntactical correctness.
10421
10422 =head2 Example Distroprefs Files
10423
10424 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10425 are really just examples and should not be used without care because
10426 they cannot fit everybody's purpose. After all the authors of the
10427 packages that ask questions had a need to ask, so you should watch
10428 their questions and adjust the examples to your environment and your
10429 needs. You have beend warned:-)
10430
10431 =head1 PROGRAMMER'S INTERFACE
10432
10433 If you do not enter the shell, the available shell commands are both
10434 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10435 functions in the calling package (C<install(...)>).  Before calling low-level
10436 commands it makes sense to initialize components of CPAN you need, e.g.:
10437
10438   CPAN::HandleConfig->load;
10439   CPAN::Shell::setup_output;
10440   CPAN::Index->reload;
10441
10442 High-level commands do such initializations automatically.
10443
10444 There's currently only one class that has a stable interface -
10445 CPAN::Shell. All commands that are available in the CPAN shell are
10446 methods of the class CPAN::Shell. Each of the commands that produce
10447 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10448 the IDs of all modules within the list.
10449
10450 =over 2
10451
10452 =item expand($type,@things)
10453
10454 The IDs of all objects available within a program are strings that can
10455 be expanded to the corresponding real objects with the
10456 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10457 list of CPAN::Module objects according to the C<@things> arguments
10458 given. In scalar context it only returns the first element of the
10459 list.
10460
10461 =item expandany(@things)
10462
10463 Like expand, but returns objects of the appropriate type, i.e.
10464 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10465 CPAN::Distribution objects for distributions. Note: it does not expand
10466 to CPAN::Author objects.
10467
10468 =item Programming Examples
10469
10470 This enables the programmer to do operations that combine
10471 functionalities that are available in the shell.
10472
10473     # install everything that is outdated on my disk:
10474     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10475
10476     # install my favorite programs if necessary:
10477     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10478         CPAN::Shell->install($mod);
10479     }
10480
10481     # list all modules on my disk that have no VERSION number
10482     for $mod (CPAN::Shell->expand("Module","/./")){
10483         next unless $mod->inst_file;
10484         # MakeMaker convention for undefined $VERSION:
10485         next unless $mod->inst_version eq "undef";
10486         print "No VERSION in ", $mod->id, "\n";
10487     }
10488
10489     # find out which distribution on CPAN contains a module:
10490     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10491
10492 Or if you want to write a cronjob to watch The CPAN, you could list
10493 all modules that need updating. First a quick and dirty way:
10494
10495     perl -e 'use CPAN; CPAN::Shell->r;'
10496
10497 If you don't want to get any output in the case that all modules are
10498 up to date, you can parse the output of above command for the regular
10499 expression //modules are up to date// and decide to mail the output
10500 only if it doesn't match. Ick?
10501
10502 If you prefer to do it more in a programmer style in one single
10503 process, maybe something like this suits you better:
10504
10505   # list all modules on my disk that have newer versions on CPAN
10506   for $mod (CPAN::Shell->expand("Module","/./")){
10507     next unless $mod->inst_file;
10508     next if $mod->uptodate;
10509     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10510         $mod->id, $mod->inst_version, $mod->cpan_version;
10511   }
10512
10513 If that gives you too much output every day, you maybe only want to
10514 watch for three modules. You can write
10515
10516   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10517
10518 as the first line instead. Or you can combine some of the above
10519 tricks:
10520
10521   # watch only for a new mod_perl module
10522   $mod = CPAN::Shell->expand("Module","mod_perl");
10523   exit if $mod->uptodate;
10524   # new mod_perl arrived, let me know all update recommendations
10525   CPAN::Shell->r;
10526
10527 =back
10528
10529 =head2 Methods in the other Classes
10530
10531 =over 4
10532
10533 =item CPAN::Author::as_glimpse()
10534
10535 Returns a one-line description of the author
10536
10537 =item CPAN::Author::as_string()
10538
10539 Returns a multi-line description of the author
10540
10541 =item CPAN::Author::email()
10542
10543 Returns the author's email address
10544
10545 =item CPAN::Author::fullname()
10546
10547 Returns the author's name
10548
10549 =item CPAN::Author::name()
10550
10551 An alias for fullname
10552
10553 =item CPAN::Bundle::as_glimpse()
10554
10555 Returns a one-line description of the bundle
10556
10557 =item CPAN::Bundle::as_string()
10558
10559 Returns a multi-line description of the bundle
10560
10561 =item CPAN::Bundle::clean()
10562
10563 Recursively runs the C<clean> method on all items contained in the bundle.
10564
10565 =item CPAN::Bundle::contains()
10566
10567 Returns a list of objects' IDs contained in a bundle. The associated
10568 objects may be bundles, modules or distributions.
10569
10570 =item CPAN::Bundle::force($method,@args)
10571
10572 Forces CPAN to perform a task that it normally would have refused to
10573 do. Force takes as arguments a method name to be called and any number
10574 of additional arguments that should be passed to the called method.
10575 The internals of the object get the needed changes so that CPAN.pm
10576 does not refuse to take the action. The C<force> is passed recursively
10577 to all contained objects. See also the section above on the C<force>
10578 and the C<fforce> pragma.
10579
10580 =item CPAN::Bundle::get()
10581
10582 Recursively runs the C<get> method on all items contained in the bundle
10583
10584 =item CPAN::Bundle::inst_file()
10585
10586 Returns the highest installed version of the bundle in either @INC or
10587 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10588 CPAN::Module::inst_file.
10589
10590 =item CPAN::Bundle::inst_version()
10591
10592 Like CPAN::Bundle::inst_file, but returns the $VERSION
10593
10594 =item CPAN::Bundle::uptodate()
10595
10596 Returns 1 if the bundle itself and all its members are uptodate.
10597
10598 =item CPAN::Bundle::install()
10599
10600 Recursively runs the C<install> method on all items contained in the bundle
10601
10602 =item CPAN::Bundle::make()
10603
10604 Recursively runs the C<make> method on all items contained in the bundle
10605
10606 =item CPAN::Bundle::readme()
10607
10608 Recursively runs the C<readme> method on all items contained in the bundle
10609
10610 =item CPAN::Bundle::test()
10611
10612 Recursively runs the C<test> method on all items contained in the bundle
10613
10614 =item CPAN::Distribution::as_glimpse()
10615
10616 Returns a one-line description of the distribution
10617
10618 =item CPAN::Distribution::as_string()
10619
10620 Returns a multi-line description of the distribution
10621
10622 =item CPAN::Distribution::author
10623
10624 Returns the CPAN::Author object of the maintainer who uploaded this
10625 distribution
10626
10627 =item CPAN::Distribution::clean()
10628
10629 Changes to the directory where the distribution has been unpacked and
10630 runs C<make clean> there.
10631
10632 =item CPAN::Distribution::containsmods()
10633
10634 Returns a list of IDs of modules contained in a distribution file.
10635 Only works for distributions listed in the 02packages.details.txt.gz
10636 file. This typically means that only the most recent version of a
10637 distribution is covered.
10638
10639 =item CPAN::Distribution::cvs_import()
10640
10641 Changes to the directory where the distribution has been unpacked and
10642 runs something like
10643
10644     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10645
10646 there.
10647
10648 =item CPAN::Distribution::dir()
10649
10650 Returns the directory into which this distribution has been unpacked.
10651
10652 =item CPAN::Distribution::force($method,@args)
10653
10654 Forces CPAN to perform a task that it normally would have refused to
10655 do. Force takes as arguments a method name to be called and any number
10656 of additional arguments that should be passed to the called method.
10657 The internals of the object get the needed changes so that CPAN.pm
10658 does not refuse to take the action. See also the section above on the
10659 C<force> and the C<fforce> pragma.
10660
10661 =item CPAN::Distribution::get()
10662
10663 Downloads the distribution from CPAN and unpacks it. Does nothing if
10664 the distribution has already been downloaded and unpacked within the
10665 current session.
10666
10667 =item CPAN::Distribution::install()
10668
10669 Changes to the directory where the distribution has been unpacked and
10670 runs the external command C<make install> there. If C<make> has not
10671 yet been run, it will be run first. A C<make test> will be issued in
10672 any case and if this fails, the install will be canceled. The
10673 cancellation can be avoided by letting C<force> run the C<install> for
10674 you.
10675
10676 This install method has only the power to install the distribution if
10677 there are no dependencies in the way. To install an object and all of
10678 its dependencies, use CPAN::Shell->install.
10679
10680 Note that install() gives no meaningful return value. See uptodate().
10681
10682 =item CPAN::Distribution::install_tested()
10683
10684 Install all the distributions that have been tested sucessfully but
10685 not yet installed. See also C<is_tested>.
10686
10687 =item CPAN::Distribution::isa_perl()
10688
10689 Returns 1 if this distribution file seems to be a perl distribution.
10690 Normally this is derived from the file name only, but the index from
10691 CPAN can contain a hint to achieve a return value of true for other
10692 filenames too.
10693
10694 =item CPAN::Distribution::is_tested()
10695
10696 List all the distributions that have been tested sucessfully but not
10697 yet installed. See also C<install_tested>.
10698
10699 =item CPAN::Distribution::look()
10700
10701 Changes to the directory where the distribution has been unpacked and
10702 opens a subshell there. Exiting the subshell returns.
10703
10704 =item CPAN::Distribution::make()
10705
10706 First runs the C<get> method to make sure the distribution is
10707 downloaded and unpacked. Changes to the directory where the
10708 distribution has been unpacked and runs the external commands C<perl
10709 Makefile.PL> or C<perl Build.PL> and C<make> there.
10710
10711 =item CPAN::Distribution::perldoc()
10712
10713 Downloads the pod documentation of the file associated with a
10714 distribution (in html format) and runs it through the external
10715 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10716 isn't available, it converts it to plain text with external
10717 command html2text and runs it through the pager specified
10718 in C<$CPAN::Config->{pager}>
10719
10720 =item CPAN::Distribution::prefs()
10721
10722 Returns the hash reference from the first matching YAML file that the
10723 user has deposited in the C<prefs_dir/> directory. The first
10724 succeeding match wins. The files in the C<prefs_dir/> are processed
10725 alphabetically and the canonical distroname (e.g.
10726 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10727 stored in the $root->{match}{distribution} attribute value.
10728 Additionally all module names contained in a distribution are matched
10729 agains the regular expressions in the $root->{match}{module} attribute
10730 value. The two match values are ANDed together. Each of the two
10731 attributes are optional.
10732
10733 =item CPAN::Distribution::prereq_pm()
10734
10735 Returns the hash reference that has been announced by a distribution
10736 as the the C<requires> and C<build_requires> elements. These can be
10737 declared either by the C<META.yml> (if authoritative) or can be
10738 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10739 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10740 a comment in the produced C<Makefile>. I<Note>: this method only works
10741 after an attempt has been made to C<make> the distribution. Returns
10742 undef otherwise.
10743
10744 =item CPAN::Distribution::readme()
10745
10746 Downloads the README file associated with a distribution and runs it
10747 through the pager specified in C<$CPAN::Config->{pager}>.
10748
10749 =item CPAN::Distribution::read_yaml()
10750
10751 Returns the content of the META.yml of this distro as a hashref. Note:
10752 works only after an attempt has been made to C<make> the distribution.
10753 Returns undef otherwise. Also returns undef if the content of META.yml
10754 is not authoritative. (The rules about what exactly makes the content
10755 authoritative are still in flux.)
10756
10757 =item CPAN::Distribution::test()
10758
10759 Changes to the directory where the distribution has been unpacked and
10760 runs C<make test> there.
10761
10762 =item CPAN::Distribution::uptodate()
10763
10764 Returns 1 if all the modules contained in the distribution are
10765 uptodate. Relies on containsmods.
10766
10767 =item CPAN::Index::force_reload()
10768
10769 Forces a reload of all indices.
10770
10771 =item CPAN::Index::reload()
10772
10773 Reloads all indices if they have not been read for more than
10774 C<$CPAN::Config->{index_expire}> days.
10775
10776 =item CPAN::InfoObj::dump()
10777
10778 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10779 inherit this method. It prints the data structure associated with an
10780 object. Useful for debugging. Note: the data structure is considered
10781 internal and thus subject to change without notice.
10782
10783 =item CPAN::Module::as_glimpse()
10784
10785 Returns a one-line description of the module in four columns: The
10786 first column contains the word C<Module>, the second column consists
10787 of one character: an equals sign if this module is already installed
10788 and uptodate, a less-than sign if this module is installed but can be
10789 upgraded, and a space if the module is not installed. The third column
10790 is the name of the module and the fourth column gives maintainer or
10791 distribution information.
10792
10793 =item CPAN::Module::as_string()
10794
10795 Returns a multi-line description of the module
10796
10797 =item CPAN::Module::clean()
10798
10799 Runs a clean on the distribution associated with this module.
10800
10801 =item CPAN::Module::cpan_file()
10802
10803 Returns the filename on CPAN that is associated with the module.
10804
10805 =item CPAN::Module::cpan_version()
10806
10807 Returns the latest version of this module available on CPAN.
10808
10809 =item CPAN::Module::cvs_import()
10810
10811 Runs a cvs_import on the distribution associated with this module.
10812
10813 =item CPAN::Module::description()
10814
10815 Returns a 44 character description of this module. Only available for
10816 modules listed in The Module List (CPAN/modules/00modlist.long.html
10817 or 00modlist.long.txt.gz)
10818
10819 =item CPAN::Module::distribution()
10820
10821 Returns the CPAN::Distribution object that contains the current
10822 version of this module.
10823
10824 =item CPAN::Module::dslip_status()
10825
10826 Returns a hash reference. The keys of the hash are the letters C<D>,
10827 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10828 language, interface and public licence respectively. The data for the
10829 DSLIP status are collected by pause.perl.org when authors register
10830 their namespaces. The values of the 5 hash elements are one-character
10831 words whose meaning is described in the table below. There are also 5
10832 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10833 verbose value of the 5 status variables.
10834
10835 Where the 'DSLIP' characters have the following meanings:
10836
10837   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
10838     i   - Idea, listed to gain consensus or as a placeholder
10839     c   - under construction but pre-alpha (not yet released)
10840     a/b - Alpha/Beta testing
10841     R   - Released
10842     M   - Mature (no rigorous definition)
10843     S   - Standard, supplied with Perl 5
10844
10845   S - Support Level:
10846     m   - Mailing-list
10847     d   - Developer
10848     u   - Usenet newsgroup comp.lang.perl.modules
10849     n   - None known, try comp.lang.perl.modules
10850     a   - abandoned; volunteers welcome to take over maintainance
10851
10852   L - Language Used:
10853     p   - Perl-only, no compiler needed, should be platform independent
10854     c   - C and perl, a C compiler will be needed
10855     h   - Hybrid, written in perl with optional C code, no compiler needed
10856     +   - C++ and perl, a C++ compiler will be needed
10857     o   - perl and another language other than C or C++
10858
10859   I - Interface Style
10860     f   - plain Functions, no references used
10861     h   - hybrid, object and function interfaces available
10862     n   - no interface at all (huh?)
10863     r   - some use of unblessed References or ties
10864     O   - Object oriented using blessed references and/or inheritance
10865
10866   P - Public License
10867     p   - Standard-Perl: user may choose between GPL and Artistic
10868     g   - GPL: GNU General Public License
10869     l   - LGPL: "GNU Lesser General Public License" (previously known as
10870           "GNU Library General Public License")
10871     b   - BSD: The BSD License
10872     a   - Artistic license alone
10873     o   - open source: appoved by www.opensource.org
10874     d   - allows distribution without restrictions
10875     r   - restricted distribtion
10876     n   - no license at all
10877
10878 =item CPAN::Module::force($method,@args)
10879
10880 Forces CPAN to perform a task that it normally would have refused to
10881 do. Force takes as arguments a method name to be called and any number
10882 of additional arguments that should be passed to the called method.
10883 The internals of the object get the needed changes so that CPAN.pm
10884 does not refuse to take the action. See also the section above on the
10885 C<force> and the C<fforce> pragma.
10886
10887 =item CPAN::Module::get()
10888
10889 Runs a get on the distribution associated with this module.
10890
10891 =item CPAN::Module::inst_file()
10892
10893 Returns the filename of the module found in @INC. The first file found
10894 is reported just like perl itself stops searching @INC when it finds a
10895 module.
10896
10897 =item CPAN::Module::available_file()
10898
10899 Returns the filename of the module found in PERL5LIB or @INC. The
10900 first file found is reported. The advantage of this method over
10901 C<inst_file> is that modules that have been tested but not yet
10902 installed are included because PERL5LIB keeps track of tested modules.
10903
10904 =item CPAN::Module::inst_version()
10905
10906 Returns the version number of the installed module in readable format.
10907
10908 =item CPAN::Module::available_version()
10909
10910 Returns the version number of the available module in readable format.
10911
10912 =item CPAN::Module::install()
10913
10914 Runs an C<install> on the distribution associated with this module.
10915
10916 =item CPAN::Module::look()
10917
10918 Changes to the directory where the distribution associated with this
10919 module has been unpacked and opens a subshell there. Exiting the
10920 subshell returns.
10921
10922 =item CPAN::Module::make()
10923
10924 Runs a C<make> on the distribution associated with this module.
10925
10926 =item CPAN::Module::manpage_headline()
10927
10928 If module is installed, peeks into the module's manpage, reads the
10929 headline and returns it. Moreover, if the module has been downloaded
10930 within this session, does the equivalent on the downloaded module even
10931 if it is not installed.
10932
10933 =item CPAN::Module::perldoc()
10934
10935 Runs a C<perldoc> on this module.
10936
10937 =item CPAN::Module::readme()
10938
10939 Runs a C<readme> on the distribution associated with this module.
10940
10941 =item CPAN::Module::test()
10942
10943 Runs a C<test> on the distribution associated with this module.
10944
10945 =item CPAN::Module::uptodate()
10946
10947 Returns 1 if the module is installed and up-to-date.
10948
10949 =item CPAN::Module::userid()
10950
10951 Returns the author's ID of the module.
10952
10953 =back
10954
10955 =head2 Cache Manager
10956
10957 Currently the cache manager only keeps track of the build directory
10958 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
10959 deletes complete directories below C<build_dir> as soon as the size of
10960 all directories there gets bigger than $CPAN::Config->{build_cache}
10961 (in MB). The contents of this cache may be used for later
10962 re-installations that you intend to do manually, but will never be
10963 trusted by CPAN itself. This is due to the fact that the user might
10964 use these directories for building modules on different architectures.
10965
10966 There is another directory ($CPAN::Config->{keep_source_where}) where
10967 the original distribution files are kept. This directory is not
10968 covered by the cache manager and must be controlled by the user. If
10969 you choose to have the same directory as build_dir and as
10970 keep_source_where directory, then your sources will be deleted with
10971 the same fifo mechanism.
10972
10973 =head2 Bundles
10974
10975 A bundle is just a perl module in the namespace Bundle:: that does not
10976 define any functions or methods. It usually only contains documentation.
10977
10978 It starts like a perl module with a package declaration and a $VERSION
10979 variable. After that the pod section looks like any other pod with the
10980 only difference being that I<one special pod section> exists starting with
10981 (verbatim):
10982
10983         =head1 CONTENTS
10984
10985 In this pod section each line obeys the format
10986
10987         Module_Name [Version_String] [- optional text]
10988
10989 The only required part is the first field, the name of a module
10990 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
10991 of the line is optional. The comment part is delimited by a dash just
10992 as in the man page header.
10993
10994 The distribution of a bundle should follow the same convention as
10995 other distributions.
10996
10997 Bundles are treated specially in the CPAN package. If you say 'install
10998 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
10999 the modules in the CONTENTS section of the pod. You can install your
11000 own Bundles locally by placing a conformant Bundle file somewhere into
11001 your @INC path. The autobundle() command which is available in the
11002 shell interface does that for you by including all currently installed
11003 modules in a snapshot bundle file.
11004
11005 =head1 PREREQUISITES
11006
11007 If you have a local mirror of CPAN and can access all files with
11008 "file:" URLs, then you only need a perl better than perl5.003 to run
11009 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11010 required for non-UNIX systems or if your nearest CPAN site is
11011 associated with a URL that is not C<ftp:>.
11012
11013 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11014 implemented for an external ftp command or for an external lynx
11015 command.
11016
11017 =head1 UTILITIES
11018
11019 =head2 Finding packages and VERSION
11020
11021 This module presumes that all packages on CPAN
11022
11023 =over 2
11024
11025 =item *
11026
11027 declare their $VERSION variable in an easy to parse manner. This
11028 prerequisite can hardly be relaxed because it consumes far too much
11029 memory to load all packages into the running program just to determine
11030 the $VERSION variable. Currently all programs that are dealing with
11031 version use something like this
11032
11033     perl -MExtUtils::MakeMaker -le \
11034         'print MM->parse_version(shift)' filename
11035
11036 If you are author of a package and wonder if your $VERSION can be
11037 parsed, please try the above method.
11038
11039 =item *
11040
11041 come as compressed or gzipped tarfiles or as zip files and contain a
11042 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11043 without much enthusiasm).
11044
11045 =back
11046
11047 =head2 Debugging
11048
11049 The debugging of this module is a bit complex, because we have
11050 interferences of the software producing the indices on CPAN, of the
11051 mirroring process on CPAN, of packaging, of configuration, of
11052 synchronicity, and of bugs within CPAN.pm.
11053
11054 For debugging the code of CPAN.pm itself in interactive mode some more
11055 or less useful debugging aid can be turned on for most packages within
11056 CPAN.pm with one of
11057
11058 =over 2
11059
11060 =item o debug package...
11061
11062 sets debug mode for packages.
11063
11064 =item o debug -package...
11065
11066 unsets debug mode for packages.
11067
11068 =item o debug all
11069
11070 turns debugging on for all packages.
11071
11072 =item o debug number
11073
11074 =back
11075
11076 which sets the debugging packages directly. Note that C<o debug 0>
11077 turns debugging off.
11078
11079 What seems quite a successful strategy is the combination of C<reload
11080 cpan> and the debugging switches. Add a new debug statement while
11081 running in the shell and then issue a C<reload cpan> and see the new
11082 debugging messages immediately without losing the current context.
11083
11084 C<o debug> without an argument lists the valid package names and the
11085 current set of packages in debugging mode. C<o debug> has built-in
11086 completion support.
11087
11088 For debugging of CPAN data there is the C<dump> command which takes
11089 the same arguments as make/test/install and outputs each object's
11090 Data::Dumper dump. If an argument looks like a perl variable and
11091 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11092 Data::Dumper directly.
11093
11094 =head2 Floppy, Zip, Offline Mode
11095
11096 CPAN.pm works nicely without network too. If you maintain machines
11097 that are not networked at all, you should consider working with file:
11098 URLs. Of course, you have to collect your modules somewhere first. So
11099 you might use CPAN.pm to put together all you need on a networked
11100 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11101 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11102 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11103 with this floppy. See also below the paragraph about CD-ROM support.
11104
11105 =head2 Basic Utilities for Programmers
11106
11107 =over 2
11108
11109 =item has_inst($module)
11110
11111 Returns true if the module is installed. Used to load all modules into
11112 the running CPAN.pm which are considered optional. The config variable
11113 C<dontload_list> can be used to intercept the C<has_inst()> call such
11114 that an optional module is not loaded despite being available. For
11115 example the following command will prevent that C<YAML.pm> is being
11116 loaded:
11117
11118     cpan> o conf dontload_list push YAML
11119
11120 See the source for details.
11121
11122 =item has_usable($module)
11123
11124 Returns true if the module is installed and is in a usable state. Only
11125 useful for a handful of modules that are used internally. See the
11126 source for details.
11127
11128 =item instance($module)
11129
11130 The constructor for all the singletons used to represent modules,
11131 distributions, authors and bundles. If the object already exists, this
11132 method returns the object, otherwise it calls the constructor.
11133
11134 =back
11135
11136 =head1 SECURITY
11137
11138 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11139 install foreign, unmasked, unsigned code on your machine. We compare
11140 to a checksum that comes from the net just as the distribution file
11141 itself. But we try to make it easy to add security on demand:
11142
11143 =head2 Cryptographically signed modules
11144
11145 Since release 1.77 CPAN.pm has been able to verify cryptographically
11146 signed module distributions using Module::Signature.  The CPAN modules
11147 can be signed by their authors, thus giving more security.  The simple
11148 unsigned MD5 checksums that were used before by CPAN protect mainly
11149 against accidental file corruption.
11150
11151 You will need to have Module::Signature installed, which in turn
11152 requires that you have at least one of Crypt::OpenPGP module or the
11153 command-line F<gpg> tool installed.
11154
11155 You will also need to be able to connect over the Internet to the public
11156 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11157
11158 The configuration parameter check_sigs is there to turn signature
11159 checking on or off.
11160
11161 =head1 EXPORT
11162
11163 Most functions in package CPAN are exported per default. The reason
11164 for this is that the primary use is intended for the cpan shell or for
11165 one-liners.
11166
11167 =head1 ENVIRONMENT
11168
11169 When the CPAN shell enters a subshell via the look command, it sets
11170 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11171 already set.
11172
11173 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11174
11175 When the config variable ftp_passive is set, all downloads will be run
11176 with the environment variable FTP_PASSIVE set to this value. This is
11177 in general a good idea as it influences both Net::FTP and LWP based
11178 connections. The same effect can be achieved by starting the cpan
11179 shell with this environment variable set. For Net::FTP alone, one can
11180 also always set passive mode by running libnetcfg.
11181
11182 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11183
11184 Populating a freshly installed perl with my favorite modules is pretty
11185 easy if you maintain a private bundle definition file. To get a useful
11186 blueprint of a bundle definition file, the command autobundle can be used
11187 on the CPAN shell command line. This command writes a bundle definition
11188 file for all modules that are installed for the currently running perl
11189 interpreter. It's recommended to run this command only once and from then
11190 on maintain the file manually under a private name, say
11191 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11192
11193     cpan> install Bundle::my_bundle
11194
11195 then answer a few questions and then go out for a coffee.
11196
11197 Maintaining a bundle definition file means keeping track of two
11198 things: dependencies and interactivity. CPAN.pm sometimes fails on
11199 calculating dependencies because not all modules define all MakeMaker
11200 attributes correctly, so a bundle definition file should specify
11201 prerequisites as early as possible. On the other hand, it's a bit
11202 annoying that many distributions need some interactive configuring. So
11203 what I try to accomplish in my private bundle file is to have the
11204 packages that need to be configured early in the file and the gentle
11205 ones later, so I can go out after a few minutes and leave CPAN.pm
11206 untended.
11207
11208 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11209
11210 Thanks to Graham Barr for contributing the following paragraphs about
11211 the interaction between perl, and various firewall configurations. For
11212 further information on firewalls, it is recommended to consult the
11213 documentation that comes with the ncftp program. If you are unable to
11214 go through the firewall with a simple Perl setup, it is very likely
11215 that you can configure ncftp so that it works for your firewall.
11216
11217 =head2 Three basic types of firewalls
11218
11219 Firewalls can be categorized into three basic types.
11220
11221 =over 4
11222
11223 =item http firewall
11224
11225 This is where the firewall machine runs a web server and to access the
11226 outside world you must do it via the web server. If you set environment
11227 variables like http_proxy or ftp_proxy to a values beginning with http://
11228 or in your web browser you have to set proxy information then you know
11229 you are running an http firewall.
11230
11231 To access servers outside these types of firewalls with perl (even for
11232 ftp) you will need to use LWP.
11233
11234 =item ftp firewall
11235
11236 This where the firewall machine runs an ftp server. This kind of
11237 firewall will only let you access ftp servers outside the firewall.
11238 This is usually done by connecting to the firewall with ftp, then
11239 entering a username like "user@outside.host.com"
11240
11241 To access servers outside these type of firewalls with perl you
11242 will need to use Net::FTP.
11243
11244 =item One way visibility
11245
11246 I say one way visibility as these firewalls try to make themselves look
11247 invisible to the users inside the firewall. An FTP data connection is
11248 normally created by sending the remote server your IP address and then
11249 listening for the connection. But the remote server will not be able to
11250 connect to you because of the firewall. So for these types of firewall
11251 FTP connections need to be done in a passive mode.
11252
11253 There are two that I can think off.
11254
11255 =over 4
11256
11257 =item SOCKS
11258
11259 If you are using a SOCKS firewall you will need to compile perl and link
11260 it with the SOCKS library, this is what is normally called a 'socksified'
11261 perl. With this executable you will be able to connect to servers outside
11262 the firewall as if it is not there.
11263
11264 =item IP Masquerade
11265
11266 This is the firewall implemented in the Linux kernel, it allows you to
11267 hide a complete network behind one IP address. With this firewall no
11268 special compiling is needed as you can access hosts directly.
11269
11270 For accessing ftp servers behind such firewalls you usually need to
11271 set the environment variable C<FTP_PASSIVE> or the config variable
11272 ftp_passive to a true value.
11273
11274 =back
11275
11276 =back
11277
11278 =head2 Configuring lynx or ncftp for going through a firewall
11279
11280 If you can go through your firewall with e.g. lynx, presumably with a
11281 command such as
11282
11283     /usr/local/bin/lynx -pscott:tiger
11284
11285 then you would configure CPAN.pm with the command
11286
11287     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11288
11289 That's all. Similarly for ncftp or ftp, you would configure something
11290 like
11291
11292     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11293
11294 Your mileage may vary...
11295
11296 =head1 FAQ
11297
11298 =over 4
11299
11300 =item 1)
11301
11302 I installed a new version of module X but CPAN keeps saying,
11303 I have the old version installed
11304
11305 Most probably you B<do> have the old version installed. This can
11306 happen if a module installs itself into a different directory in the
11307 @INC path than it was previously installed. This is not really a
11308 CPAN.pm problem, you would have the same problem when installing the
11309 module manually. The easiest way to prevent this behaviour is to add
11310 the argument C<UNINST=1> to the C<make install> call, and that is why
11311 many people add this argument permanently by configuring
11312
11313   o conf make_install_arg UNINST=1
11314
11315 =item 2)
11316
11317 So why is UNINST=1 not the default?
11318
11319 Because there are people who have their precise expectations about who
11320 may install where in the @INC path and who uses which @INC array. In
11321 fine tuned environments C<UNINST=1> can cause damage.
11322
11323 =item 3)
11324
11325 I want to clean up my mess, and install a new perl along with
11326 all modules I have. How do I go about it?
11327
11328 Run the autobundle command for your old perl and optionally rename the
11329 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11330 with the Configure option prefix, e.g.
11331
11332     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11333
11334 Install the bundle file you produced in the first step with something like
11335
11336     cpan> install Bundle::mybundle
11337
11338 and you're done.
11339
11340 =item 4)
11341
11342 When I install bundles or multiple modules with one command
11343 there is too much output to keep track of.
11344
11345 You may want to configure something like
11346
11347   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11348   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11349
11350 so that STDOUT is captured in a file for later inspection.
11351
11352
11353 =item 5)
11354
11355 I am not root, how can I install a module in a personal directory?
11356
11357 First of all, you will want to use your own configuration, not the one
11358 that your root user installed. If you do not have permission to write
11359 in the cpan directory that root has configured, you will be asked if
11360 you want to create your own config. Answering "yes" will bring you into
11361 CPAN's configuration stage, using the system config for all defaults except
11362 things that have to do with CPAN's work directory, saving your choices to
11363 your MyConfig.pm file.
11364
11365 You can also manually initiate this process with the following command:
11366
11367     % perl -MCPAN -e 'mkmyconfig'
11368
11369 or by running
11370
11371     mkmyconfig
11372
11373 from the CPAN shell.
11374
11375 You will most probably also want to configure something like this:
11376
11377   o conf makepl_arg "LIB=~/myperl/lib \
11378                     INSTALLMAN1DIR=~/myperl/man/man1 \
11379                     INSTALLMAN3DIR=~/myperl/man/man3 \
11380                     INSTALLSCRIPT=~/myperl/bin \
11381                     INSTALLBIN=~/myperl/bin"
11382
11383 and then (oh joy) the equivalent command for Module::Build.
11384
11385 You can make this setting permanent like all C<o conf> settings with
11386 C<o conf commit> or by setting C<auto_commit> beforehand.
11387
11388 You will have to add ~/myperl/man to the MANPATH environment variable
11389 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11390 including
11391
11392   use lib "$ENV{HOME}/myperl/lib";
11393
11394 or setting the PERL5LIB environment variable.
11395
11396 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11397 that for Windows we use the File::HomeDir module that provides an
11398 equivalent to the concept of the home directory on Unix.
11399
11400 Another thing you should bear in mind is that the UNINST parameter can
11401 be dnagerous when you are installing into a private area because you
11402 might accidentally remove modules that other people depend on that are
11403 not using the private area.
11404
11405 =item 6)
11406
11407 How to get a package, unwrap it, and make a change before building it?
11408
11409 Have a look at the C<look> (!) command.
11410
11411 =item 7)
11412
11413 I installed a Bundle and had a couple of fails. When I
11414 retried, everything resolved nicely. Can this be fixed to work
11415 on first try?
11416
11417 The reason for this is that CPAN does not know the dependencies of all
11418 modules when it starts out. To decide about the additional items to
11419 install, it just uses data found in the META.yml file or the generated
11420 Makefile. An undetected missing piece breaks the process. But it may
11421 well be that your Bundle installs some prerequisite later than some
11422 depending item and thus your second try is able to resolve everything.
11423 Please note, CPAN.pm does not know the dependency tree in advance and
11424 cannot sort the queue of things to install in a topologically correct
11425 order. It resolves perfectly well IF all modules declare the
11426 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11427 the C<requires> stanza of Module::Build. For bundles which fail and
11428 you need to install often, it is recommended to sort the Bundle
11429 definition file manually.
11430
11431 =item 8)
11432
11433 In our intranet we have many modules for internal use. How
11434 can I integrate these modules with CPAN.pm but without uploading
11435 the modules to CPAN?
11436
11437 Have a look at the CPAN::Site module.
11438
11439 =item 9)
11440
11441 When I run CPAN's shell, I get an error message about things in my
11442 /etc/inputrc (or ~/.inputrc) file.
11443
11444 These are readline issues and can only be fixed by studying readline
11445 configuration on your architecture and adjusting the referenced file
11446 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11447 and edit them. Quite often harmless changes like uppercasing or
11448 lowercasing some arguments solves the problem.
11449
11450 =item 10)
11451
11452 Some authors have strange characters in their names.
11453
11454 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11455 expecting ISO-8859-1 charset, a converter can be activated by setting
11456 term_is_latin to a true value in your config file. One way of doing so
11457 would be
11458
11459     cpan> o conf term_is_latin 1
11460
11461 If other charset support is needed, please file a bugreport against
11462 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11463 the support or maybe UTF-8 terminals become widely available.
11464
11465 =item 11)
11466
11467 When an install fails for some reason and then I correct the error
11468 condition and retry, CPAN.pm refuses to install the module, saying
11469 C<Already tried without success>.
11470
11471 Use the force pragma like so
11472
11473   force install Foo::Bar
11474
11475 Or you can use
11476
11477   look Foo::Bar
11478
11479 and then 'make install' directly in the subshell.
11480
11481 =item 12)
11482
11483 How do I install a "DEVELOPER RELEASE" of a module?
11484
11485 By default, CPAN will install the latest non-developer release of a
11486 module. If you want to install a dev release, you have to specify the
11487 partial path starting with the author id to the tarball you wish to
11488 install, like so:
11489
11490     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11491
11492 Note that you can use the C<ls> command to get this path listed.
11493
11494 =item 13)
11495
11496 How do I install a module and all its dependencies from the commandline,
11497 without being prompted for anything, despite my CPAN configuration
11498 (or lack thereof)?
11499
11500 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11501 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11502 asked any questions at all (assuming the modules you are installing are
11503 nice about obeying that variable as well):
11504
11505     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11506
11507 =item 14)
11508
11509 How do I create a Module::Build based Build.PL derived from an
11510 ExtUtils::MakeMaker focused Makefile.PL?
11511
11512 http://search.cpan.org/search?query=Module::Build::Convert
11513
11514 http://accognoscere.org/papers/perl-module-build-convert/module-build-convert.html
11515
11516 =item 15)
11517
11518 What's the best CPAN site for me?
11519
11520 The urllist config parameter is yours. You can add and remove sites at
11521 will. You should find out which sites have the best uptodateness,
11522 bandwidth, reliability, etc. and are topologically close to you. Some
11523 people prefer fast downloads, others uptodateness, others reliability.
11524 You decide which to try in which order.
11525
11526 Henk P. Penning maintains a site that collects data about CPAN sites:
11527
11528   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11529
11530 =back
11531
11532 =head1 COMPATIBILITY
11533
11534 =head2 OLD PERL VERSIONS
11535
11536 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11537 newer versions. It is getting more and more difficult to get the
11538 minimal prerequisites working on older perls. It is close to
11539 impossible to get the whole Bundle::CPAN working there. If you're in
11540 the position to have only these old versions, be advised that CPAN is
11541 designed to work fine without the Bundle::CPAN installed.
11542
11543 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11544 compatible with ancient perls and that File::Temp is listed as a
11545 prerequisite but CPAN has reasonable workarounds if it is missing.
11546
11547 =head2 CPANPLUS
11548
11549 This module and its competitor, the CPANPLUS module, are both much
11550 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11551 more modular but it was never tried to make it compatible with CPAN.pm.
11552
11553 =head1 SECURITY ADVICE
11554
11555 This software enables you to upgrade software on your computer and so
11556 is inherently dangerous because the newly installed software may
11557 contain bugs and may alter the way your computer works or even make it
11558 unusable. Please consider backing up your data before every upgrade.
11559
11560 =head1 BUGS
11561
11562 Please report bugs via http://rt.cpan.org/
11563
11564 Before submitting a bug, please make sure that the traditional method
11565 of building a Perl module package from a shell by following the
11566 installation instructions of that package still works in your
11567 environment.
11568
11569 =head1 AUTHOR
11570
11571 Andreas Koenig C<< <andk@cpan.org> >>
11572
11573 =head1 LICENSE
11574
11575 This program is free software; you can redistribute it and/or
11576 modify it under the same terms as Perl itself.
11577
11578 See L<http://www.perl.com/perl/misc/Artistic.html>
11579
11580 =head1 TRANSLATIONS
11581
11582 Kawai,Takanori provides a Japanese translation of this manpage at
11583 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11584
11585 =head1 SEE ALSO
11586
11587 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11588
11589 =cut
11590
11591