lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.91';
   5 $CPAN::VERSION = eval $CPAN::VERSION if $CPAN::VERSION =~ /_/;
   6
   7 use CPAN::HandleConfig;
   8 use CPAN::Version;
   9 use CPAN::Debug;
  10 use CPAN::Queue;
  11 use CPAN::Tarzip;
  12 use 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 (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
 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     if ($yaml_module eq "YAML"
 374         &&
 375         $CPAN::META->has_inst($yaml_module)
 376         &&
 377         $YAML::VERSION < 0.60
 378         &&
 379         !$Have_warned->{"YAML"}++
 380        ) {
 381         $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
 382                                 "I'll continue but problems are *very* likely to happen.\n"
 383                                );
 384         $CPAN::Frontend->mysleep(5);
 385     }
 386     return $yaml_module;
 387 }
 388
 389 # CPAN::_yaml_loadfile
 390 sub _yaml_loadfile {
 391     my($self,$local_file) = @_;
 392     return +[] unless -s $local_file;
 393     my $yaml_module = _yaml_module;
 394     if ($CPAN::META->has_inst($yaml_module)) {
 395         my $code;
 396         if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
 397             my @yaml;
 398             eval { @yaml = $code->($local_file); };
 399             if ($@) {
 400                 # this shall not be done by the frontend
 401                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 402             }
 403             return \@yaml;
 404         } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
 405             local *FH;
 406             open FH, $local_file or die "Could not open '$local_file': $!";
 407             local $/;
 408             my $ystream = <FH>;
 409             my @yaml;
 410             eval { @yaml = $code->($ystream); };
 411             if ($@) {
 412                 # this shall not be done by the frontend
 413                 die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
 414             }
 415             return \@yaml;
 416         }
 417     } else {
 418         # this shall not be done by the frontend
 419         die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
 420     }
 421     return +[];
 422 }
 423
 424 # CPAN::_yaml_dumpfile
 425 sub _yaml_dumpfile {
 426     my($self,$local_file,@what) = @_;
 427     my $yaml_module = _yaml_module;
 428     if ($CPAN::META->has_inst($yaml_module)) {
 429         my $code;
 430         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 431             $code = UNIVERSAL::can($yaml_module, "Dump");
 432             eval { print $local_file $code->(@what) };
 433         } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
 434             eval { $code->($local_file,@what); };
 435         } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
 436             local *FH;
 437             open FH, ">$local_file" or die "Could not open '$local_file': $!";
 438             print FH $code->(@what);
 439         }
 440         if ($@) {
 441             die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
 442         }
 443     } else {
 444         if (UNIVERSAL::isa($local_file, "FileHandle")) {
 445             # I think this case does not justify a warning at all
 446         } else {
 447             die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
 448         }
 449     }
 450 }
 451
 452 sub _init_sqlite () {
 453     unless ($CPAN::META->has_inst("CPAN::SQLite")) {
 454         $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
 455             unless $Have_warned->{"CPAN::SQLite"}++;
 456         return;
 457     }
 458     require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
 459     $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
 460 }
 461
 462 {
 463     my $negative_cache = {};
 464     sub _sqlite_running {
 465         if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
 466             # need to cache the result, otherwise too slow
 467             return $negative_cache->{fact};
 468         } else {
 469             $negative_cache = {}; # reset
 470         }
 471         my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
 472         return $ret if $ret; # fast anyway
 473         $negative_cache->{time} = time;
 474         return $negative_cache->{fact} = $ret;
 475     }
 476 }
 477
 478 package CPAN::CacheMgr;
 479 use strict;
 480 @CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
 481 use File::Find;
 482
 483 package CPAN::FTP;
 484 use strict;
 485 use Fcntl qw(:flock);
 486 use vars qw($Ua $Thesite $ThesiteURL $Themethod);
 487 @CPAN::FTP::ISA = qw(CPAN::Debug);
 488
 489 package CPAN::LWP::UserAgent;
 490 use strict;
 491 use vars qw(@ISA $USER $PASSWD $SETUPDONE);
 492 # we delay requiring LWP::UserAgent and setting up inheritance until we need it
 493
 494 package CPAN::Complete;
 495 use strict;
 496 @CPAN::Complete::ISA = qw(CPAN::Debug);
 497 # Q: where is the "How do I add a new command" HOWTO?
 498 # A: svn diff -r 1048:1049 where andk added the report command
 499 @CPAN::Complete::COMMANDS = sort qw(
 500                                     ! a b d h i m o q r u
 501                                     autobundle
 502                                     clean
 503                                     cvs_import
 504                                     dump
 505                                     failed
 506                                     force
 507                                     fforce
 508                                     hosts
 509                                     install
 510                                     install_tested
 511                                     is_tested
 512                                     look
 513                                     ls
 514                                     make
 515                                     mkmyconfig
 516                                     notest
 517                                     perldoc
 518                                     readme
 519                                     recent
 520                                     recompile
 521                                     reload
 522                                     report
 523                                     reports
 524                                     scripts
 525                                     test
 526                                     upgrade
 527 );
 528
 529 package CPAN::Index;
 530 use strict;
 531 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 532 @CPAN::Index::ISA = qw(CPAN::Debug);
 533 $LAST_TIME ||= 0;
 534 $DATE_OF_03 ||= 0;
 535 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 536 sub PROTOCOL { 2.0 }
 537
 538 package CPAN::InfoObj;
 539 use strict;
 540 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 541
 542 package CPAN::Author;
 543 use strict;
 544 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 545
 546 package CPAN::Distribution;
 547 use strict;
 548 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 549
 550 package CPAN::Bundle;
 551 use strict;
 552 @CPAN::Bundle::ISA = qw(CPAN::Module);
 553
 554 package CPAN::Module;
 555 use strict;
 556 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 557
 558 package CPAN::Exception::RecursiveDependency;
 559 use strict;
 560 use overload '""' => "as_string";
 561
 562 # a module sees its distribution (no version)
 563 # a distribution sees its prereqs (which are module names) (usually with versions)
 564 # a bundle sees its module names and/or its distributions (no version)
 565
 566 sub new {
 567     my($class) = shift;
 568     my($deps) = shift;
 569     my (@deps,%seen,$loop_starts_with);
 570   DCHAIN: for my $dep (@$deps) {
 571         push @deps, {name => $dep, display_as => $dep};
 572         if ($seen{$dep}++){
 573             $loop_starts_with = $dep;
 574             last DCHAIN;
 575         }
 576     }
 577     my $in_loop = 0;
 578     for my $i (0..$#deps) {
 579         my $x = $deps[$i]{name};
 580         $in_loop ||= $x eq $loop_starts_with;
 581         my $xo = CPAN::Shell->expandany($x) or next;
 582         if ($xo->isa("CPAN::Module")) {
 583             my $have = $xo->inst_version || "N/A";
 584             my($want,$d,$want_type);
 585             if ($i>0 and $d = $deps[$i-1]{name}) {
 586                 my $do = CPAN::Shell->expandany($d);
 587                 $want = $do->{prereq_pm}{requires}{$x};
 588                 if (defined $want) {
 589                     $want_type = "requires: ";
 590                 } else {
 591                     $want = $do->{prereq_pm}{build_requires}{$x};
 592                     if (defined $want) {
 593                         $want_type = "build_requires: ";
 594                     } else {
 595                         $want_type = "unknown status";
 596                         $want = "???";
 597                     }
 598                 }
 599             } else {
 600                 $want = $xo->cpan_version;
 601                 $want_type = "want: ";
 602             }
 603             $deps[$i]{have} = $have;
 604             $deps[$i]{want_type} = $want_type;
 605             $deps[$i]{want} = $want;
 606             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 607         } elsif ($xo->isa("CPAN::Distribution")) {
 608             $deps[$i]{display_as} = $xo->pretty_id;
 609             if ($in_loop) {
 610                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 611             } else {
 612                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 613             }
 614             $xo->store_persistent_state; # otherwise I will not reach
 615                                          # all involved parties for
 616                                          # the next session
 617         }
 618     }
 619     bless { deps => \@deps }, $class;
 620 }
 621
 622 sub as_string {
 623     my($self) = shift;
 624     my $ret = "\nRecursive dependency detected:\n    ";
 625     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 626     $ret .= ".\nCannot resolve.\n";
 627     $ret;
 628 }
 629
 630 package CPAN::Exception::yaml_not_installed;
 631 use strict;
 632 use overload '""' => "as_string";
 633
 634 sub new {
 635     my($class,$module,$file,$during) = @_;
 636     bless { module => $module, file => $file, during => $during }, $class;
 637 }
 638
 639 sub as_string {
 640     my($self) = shift;
 641     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 642 }
 643
 644 package CPAN::Exception::yaml_process_error;
 645 use strict;
 646 use overload '""' => "as_string";
 647
 648 sub new {
 649     my($class,$module,$file,$during,$error) = @_;
 650     bless { module => $module,
 651             file => $file,
 652             during => $during,
 653             error => $error }, $class;
 654 }
 655
 656 sub as_string {
 657     my($self) = shift;
 658     if ($self->{during}) {
 659         if ($self->{file}) {
 660             if ($self->{module}) {
 661                 if ($self->{error}) {
 662                     return "Alert: While trying to '$self->{during}' YAML file\n".
 663                         " '$self->{file}'\n".
 664                             "with '$self->{module}' the following error was encountered:\n".
 665                                 "  $self->{error}\n";
 666                 } else {
 667                     return "Alert: While trying to '$self->{during}' YAML file\n".
 668                         " '$self->{file}'\n".
 669                             "with '$self->{module}' some unknown error was encountered\n";
 670                 }
 671             } else {
 672                 return "Alert: While trying to '$self->{during}' YAML file\n".
 673                     " '$self->{file}'\n".
 674                         "some unknown error was encountered\n";
 675             }
 676         } else {
 677             return "Alert: While trying to '$self->{during}' some YAML file\n".
 678                     "some unknown error was encountered\n";
 679         }
 680     } else {
 681         return "Alert: unknown error encountered\n";
 682     }
 683 }
 684
 685 package CPAN::Prompt; use overload '""' => "as_string";
 686 use vars qw($prompt);
 687 $prompt = "cpan> ";
 688 $CPAN::CurrentCommandId ||= 0;
 689 sub new {
 690     bless {}, shift;
 691 }
 692 sub as_string {
 693     my $word = "cpan";
 694     unless ($CPAN::META->{LOCK}) {
 695         $word = "nolock_cpan";
 696     }
 697     if ($CPAN::Config->{commandnumber_in_prompt}) {
 698         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 699     } else {
 700         "$word> ";
 701     }
 702 }
 703
 704 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 705 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 706 # planned are things like age or quality
 707 sub new {
 708     my($class,%args) = @_;
 709     bless {
 710            %args
 711           }, $class;
 712 }
 713 sub as_string {
 714     my($self) = @_;
 715     $self->text;
 716 }
 717 sub text {
 718     my($self,$set) = @_;
 719     if (defined $set) {
 720         $self->{TEXT} = $set;
 721     }
 722     $self->{TEXT};
 723 }
 724
 725 package CPAN::Distrostatus;
 726 use overload '""' => "as_string",
 727     fallback => 1;
 728 sub new {
 729     my($class,$arg) = @_;
 730     bless {
 731            TEXT => $arg,
 732            FAILED => substr($arg,0,2) eq "NO",
 733            COMMANDID => $CPAN::CurrentCommandId,
 734            TIME => time,
 735           }, $class;
 736 }
 737 sub commandid { shift->{COMMANDID} }
 738 sub failed { shift->{FAILED} }
 739 sub text {
 740     my($self,$set) = @_;
 741     if (defined $set) {
 742         $self->{TEXT} = $set;
 743     }
 744     $self->{TEXT};
 745 }
 746 sub as_string {
 747     my($self) = @_;
 748     $self->text;
 749 }
 750
 751 package CPAN::Shell;
 752 use strict;
 753 use vars qw(
 754             $ADVANCED_QUERY
 755             $AUTOLOAD
 756             $COLOR_REGISTERED
 757             $autoload_recursion
 758             $reload
 759             @ISA
 760            );
 761 @CPAN::Shell::ISA = qw(CPAN::Debug);
 762 $COLOR_REGISTERED ||= 0;
 763
 764 {
 765     $autoload_recursion   ||= 0;
 766
 767     #-> sub CPAN::Shell::AUTOLOAD ;
 768     sub AUTOLOAD {
 769         $autoload_recursion++;
 770         my($l) = $AUTOLOAD;
 771         my $class = shift(@_);
 772         # warn "autoload[$l] class[$class]";
 773         $l =~ s/.*:://;
 774         if ($CPAN::Signal) {
 775             warn "Refusing to autoload '$l' while signal pending";
 776             $autoload_recursion--;
 777             return;
 778         }
 779         if ($autoload_recursion > 1) {
 780             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 781             warn "Refusing to autoload $fullcommand in recursion\n";
 782             $autoload_recursion--;
 783             return;
 784         }
 785         if ($l =~ /^w/) {
 786             # XXX needs to be reconsidered
 787             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 788                 CPAN::WAIT->$l(@_);
 789             } else {
 790                 $CPAN::Frontend->mywarn(qq{
 791 Commands starting with "w" require CPAN::WAIT to be installed.
 792 Please consider installing CPAN::WAIT to use the fulltext index.
 793 For this you just need to type
 794     install CPAN::WAIT
 795 });
 796             }
 797         } else {
 798             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 799                                     qq{Type ? for help.
 800 });
 801         }
 802         $autoload_recursion--;
 803     }
 804 }
 805
 806 package CPAN;
 807 use strict;
 808
 809 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 810
 811 # from here on only subs.
 812 ################################################################################
 813
 814 sub _perl_fingerprint {
 815     my($self,$other_fingerprint) = @_;
 816     my $dll = eval {OS2::DLLname()};
 817     my $mtime_dll = 0;
 818     if (defined $dll) {
 819         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 820     }
 821     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 822     my $this_fingerprint = {
 823                             '$^X' => $^X,
 824                             sitearchexp => $Config::Config{sitearchexp},
 825                             'mtime_$^X' => $mtime_perl,
 826                             'mtime_dll' => $mtime_dll,
 827                            };
 828     if ($other_fingerprint) {
 829         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 830             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 831         }
 832         # mandatory keys since 1.88_57
 833         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 834             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 835         }
 836         return 1;
 837     } else {
 838         return $this_fingerprint;
 839     }
 840 }
 841
 842 sub suggest_myconfig () {
 843   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 844         $CPAN::Frontend->myprint("You don't seem to have a user ".
 845                                  "configuration (MyConfig.pm) yet.\n");
 846         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 847                                               "user configuration now? (Y/n)",
 848                                               "yes");
 849         if($new =~ m{^y}i) {
 850             CPAN::Shell->mkmyconfig();
 851             return &checklock;
 852         } else {
 853             $CPAN::Frontend->mydie("OK, giving up.");
 854         }
 855     }
 856 }
 857
 858 #-> sub CPAN::all_objects ;
 859 sub all_objects {
 860     my($mgr,$class) = @_;
 861     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 862     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 863     CPAN::Index->reload;
 864     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 865 }
 866
 867 # Called by shell, not in batch mode. In batch mode I see no risk in
 868 # having many processes updating something as installations are
 869 # continually checked at runtime. In shell mode I suspect it is
 870 # unintentional to open more than one shell at a time
 871
 872 #-> sub CPAN::checklock ;
 873 sub checklock {
 874     my($self) = @_;
 875     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 876     if (-f $lockfile && -M _ > 0) {
 877         my $fh = FileHandle->new($lockfile) or
 878             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 879         my $otherpid  = <$fh>;
 880         my $otherhost = <$fh>;
 881         $fh->close;
 882         if (defined $otherpid && $otherpid) {
 883             chomp $otherpid;
 884         }
 885         if (defined $otherhost && $otherhost) {
 886             chomp $otherhost;
 887         }
 888         my $thishost  = hostname();
 889         if (defined $otherhost && defined $thishost &&
 890             $otherhost ne '' && $thishost ne '' &&
 891             $otherhost ne $thishost) {
 892             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 893                                            "reports other host $otherhost and other ".
 894                                            "process $otherpid.\n".
 895                                            "Cannot proceed.\n"));
 896         } elsif ($RUN_DEGRADED) {
 897             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 898         } elsif (defined $otherpid && $otherpid) {
 899             return if $$ == $otherpid; # should never happen
 900             $CPAN::Frontend->mywarn(
 901                                     qq{
 902 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 903 });
 904             if (kill 0, $otherpid) {
 905                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 906                 my($ans) =
 907                     CPAN::Shell::colorable_makemaker_prompt
 908                         (qq{Shall I try to run in degraded }.
 909                          qq{mode? (Y/n)},"y");
 910                 if ($ans =~ /^y/i) {
 911                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 912 Please report if something unexpected happens\n");
 913                     $RUN_DEGRADED = 1;
 914                     for ($CPAN::Config) {
 915                         # XXX
 916                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 917                         $_->{commandnumber_in_prompt} = 0; # visibility
 918                         $_->{histfile} = "";               # who should win otherwise?
 919                         $_->{cache_metadata} = 0;          # better would be a lock?
 920                         $_->{use_sqlite} = 0;              # better would be a write lock!
 921                     }
 922                 } else {
 923                     $CPAN::Frontend->mydie("
 924 You may want to kill the other job and delete the lockfile. On UNIX try:
 925     kill $otherpid
 926     rm $lockfile
 927 ");
 928                 }
 929             } elsif (-w $lockfile) {
 930                 my($ans) =
 931                     CPAN::Shell::colorable_makemaker_prompt
 932                         (qq{Other job not responding. Shall I overwrite }.
 933                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 934                 $CPAN::Frontend->myexit("Ok, bye\n")
 935                     unless $ans =~ /^y/i;
 936             } else {
 937                 Carp::croak(
 938                             qq{Lockfile '$lockfile' not writeable by you. }.
 939                             qq{Cannot proceed.\n}.
 940                             qq{    On UNIX try:\n}.
 941                             qq{    rm '$lockfile'\n}.
 942                             qq{  and then rerun us.\n}
 943                            );
 944             }
 945         } else {
 946             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 947                                            "'$lockfile', please remove. Cannot proceed.\n"));
 948         }
 949     }
 950     my $dotcpan = $CPAN::Config->{cpan_home};
 951     eval { File::Path::mkpath($dotcpan);};
 952     if ($@) {
 953         # A special case at least for Jarkko.
 954         my $firsterror = $@;
 955         my $seconderror;
 956         my $symlinkcpan;
 957         if (-l $dotcpan) {
 958             $symlinkcpan = readlink $dotcpan;
 959             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 960             eval { File::Path::mkpath($symlinkcpan); };
 961             if ($@) {
 962                 $seconderror = $@;
 963             } else {
 964                 $CPAN::Frontend->mywarn(qq{
 965 Working directory $symlinkcpan created.
 966 });
 967             }
 968         }
 969         unless (-d $dotcpan) {
 970             my $mess = qq{
 971 Your configuration suggests "$dotcpan" as your
 972 CPAN.pm working directory. I could not create this directory due
 973 to this error: $firsterror\n};
 974             $mess .= qq{
 975 As "$dotcpan" is a symlink to "$symlinkcpan",
 976 I tried to create that, but I failed with this error: $seconderror
 977 } if $seconderror;
 978             $mess .= qq{
 979 Please make sure the directory exists and is writable.
 980 };
 981             $CPAN::Frontend->myprint($mess);
 982             return suggest_myconfig;
 983         }
 984     } # $@ after eval mkpath $dotcpan
 985     if (0) { # to test what happens when a race condition occurs
 986         for (reverse 1..10) {
 987             print $_, "\n";
 988             sleep 1;
 989         }
 990     }
 991     # locking
 992     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 993         my $fh;
 994         unless ($fh = FileHandle->new("+>>$lockfile")) {
 995             if ($! =~ /Permission/) {
 996                 $CPAN::Frontend->myprint(qq{
 997
 998 Your configuration suggests that CPAN.pm should use a working
 999 directory of
1000     $CPAN::Config->{cpan_home}
1001 Unfortunately we could not create the lock file
1002     $lockfile
1003 due to permission problems.
1004
1005 Please make sure that the configuration variable
1006     \$CPAN::Config->{cpan_home}
1007 points to a directory where you can write a .lock file. You can set
1008 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1009 \@INC path;
1010 });
1011                 return suggest_myconfig;
1012             }
1013         }
1014         my $sleep = 1;
1015         while (!flock $fh, LOCK_EX|LOCK_NB) {
1016             if ($sleep>10) {
1017                 $CPAN::Frontend->mydie("Giving up\n");
1018             }
1019             $CPAN::Frontend->mysleep($sleep++);
1020             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1021         }
1022
1023         seek $fh, 0, 0;
1024         truncate $fh, 0;
1025         $fh->print($$, "\n");
1026         $fh->print(hostname(), "\n");
1027         $self->{LOCK} = $lockfile;
1028         $self->{LOCKFH} = $fh;
1029     }
1030     $SIG{TERM} = sub {
1031         my $sig = shift;
1032         &cleanup;
1033         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1034     };
1035     $SIG{INT} = sub {
1036       # no blocks!!!
1037         my $sig = shift;
1038         &cleanup if $Signal;
1039         die "Got yet another signal" if $Signal > 1;
1040         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1041         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1042         $Signal++;
1043     };
1044
1045 #       From: Larry Wall <larry@wall.org>
1046 #       Subject: Re: deprecating SIGDIE
1047 #       To: perl5-porters@perl.org
1048 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1049 #
1050 #       The original intent of __DIE__ was only to allow you to substitute one
1051 #       kind of death for another on an application-wide basis without respect
1052 #       to whether you were in an eval or not.  As a global backstop, it should
1053 #       not be used any more lightly (or any more heavily :-) than class
1054 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1055 #       be politely squashed.  Any bug that causes every eval {} to have to be
1056 #       modified should be not so politely squashed.
1057 #
1058 #       Those are my current opinions.  It is also my optinion that polite
1059 #       arguments degenerate to personal arguments far too frequently, and that
1060 #       when they do, it's because both people wanted it to, or at least didn't
1061 #       sufficiently want it not to.
1062 #
1063 #       Larry
1064
1065     # global backstop to cleanup if we should really die
1066     $SIG{__DIE__} = \&cleanup;
1067     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1068 }
1069
1070 #-> sub CPAN::DESTROY ;
1071 sub DESTROY {
1072     &cleanup; # need an eval?
1073 }
1074
1075 #-> sub CPAN::anycwd ;
1076 sub anycwd () {
1077     my $getcwd;
1078     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1079     CPAN->$getcwd();
1080 }
1081
1082 #-> sub CPAN::cwd ;
1083 sub cwd {Cwd::cwd();}
1084
1085 #-> sub CPAN::getcwd ;
1086 sub getcwd {Cwd::getcwd();}
1087
1088 #-> sub CPAN::fastcwd ;
1089 sub fastcwd {Cwd::fastcwd();}
1090
1091 #-> sub CPAN::backtickcwd ;
1092 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1093
1094 #-> sub CPAN::find_perl ;
1095 sub find_perl {
1096     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1097     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1098     my $candidate = File::Spec->catfile($pwd,$^X);
1099     $perl ||= $candidate if MM->maybe_command($candidate);
1100
1101     unless ($perl) {
1102         my ($component,$perl_name);
1103       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1104             PATH_COMPONENT: foreach $component (File::Spec->path(),
1105                                                 $Config::Config{'binexp'}) {
1106                   next unless defined($component) && $component;
1107                   my($abs) = File::Spec->catfile($component,$perl_name);
1108                   if (MM->maybe_command($abs)) {
1109                       $perl = $abs;
1110                       last DIST_PERLNAME;
1111                   }
1112               }
1113           }
1114     }
1115
1116     return $perl;
1117 }
1118
1119
1120 #-> sub CPAN::exists ;
1121 sub exists {
1122     my($mgr,$class,$id) = @_;
1123     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1124     CPAN::Index->reload;
1125     ### Carp::croak "exists called without class argument" unless $class;
1126     $id ||= "";
1127     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1128     my $exists;
1129     if (CPAN::_sqlite_running) {
1130         $exists = (exists $META->{readonly}{$class}{$id} or
1131                    $CPAN::SQLite->set($class, $id));
1132     } else {
1133         $exists =  exists $META->{readonly}{$class}{$id};
1134     }
1135     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1136 }
1137
1138 #-> sub CPAN::delete ;
1139 sub delete {
1140   my($mgr,$class,$id) = @_;
1141   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1142   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1143 }
1144
1145 #-> sub CPAN::has_usable
1146 # has_inst is sometimes too optimistic, we should replace it with this
1147 # has_usable whenever a case is given
1148 sub has_usable {
1149     my($self,$mod,$message) = @_;
1150     return 1 if $HAS_USABLE->{$mod};
1151     my $has_inst = $self->has_inst($mod,$message);
1152     return unless $has_inst;
1153     my $usable;
1154     $usable = {
1155                LWP => [ # we frequently had "Can't locate object
1156                         # method "new" via package "LWP::UserAgent" at
1157                         # (eval 69) line 2006
1158                        sub {require LWP},
1159                        sub {require LWP::UserAgent},
1160                        sub {require HTTP::Request},
1161                        sub {require URI::URL},
1162                       ],
1163                'Net::FTP' => [
1164                             sub {require Net::FTP},
1165                             sub {require Net::Config},
1166                            ],
1167                'File::HomeDir' => [
1168                                    sub {require File::HomeDir;
1169                                         unless (File::HomeDir::->VERSION >= 0.52){
1170                                             for ("Will not use File::HomeDir, need 0.52\n") {
1171                                                 $CPAN::Frontend->mywarn($_);
1172                                                 die $_;
1173                                             }
1174                                         }
1175                                     },
1176                                   ],
1177                'Archive::Tar' => [
1178                                   sub {require Archive::Tar;
1179                                        unless (Archive::Tar::->VERSION >= 1.00) {
1180                                             for ("Will not use Archive::Tar, need 1.00\n") {
1181                                                 $CPAN::Frontend->mywarn($_);
1182                                                 die $_;
1183                                             }
1184                                        }
1185                                   },
1186                                  ],
1187               };
1188     if ($usable->{$mod}) {
1189         for my $c (0..$#{$usable->{$mod}}) {
1190             my $code = $usable->{$mod}[$c];
1191             my $ret = eval { &$code() };
1192             $ret = "" unless defined $ret;
1193             if ($@) {
1194                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1195                 return;
1196             }
1197         }
1198     }
1199     return $HAS_USABLE->{$mod} = 1;
1200 }
1201
1202 #-> sub CPAN::has_inst
1203 sub has_inst {
1204     my($self,$mod,$message) = @_;
1205     Carp::croak("CPAN->has_inst() called without an argument")
1206         unless defined $mod;
1207     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1208         keys %{$CPAN::Config->{dontload_hash}||{}},
1209             @{$CPAN::Config->{dontload_list}||[]};
1210     if (defined $message && $message eq "no"  # afair only used by Nox
1211         ||
1212         $dont{$mod}
1213        ) {
1214       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1215       return 0;
1216     }
1217     my $file = $mod;
1218     my $obj;
1219     $file =~ s|::|/|g;
1220     $file .= ".pm";
1221     if ($INC{$file}) {
1222         # checking %INC is wrong, because $INC{LWP} may be true
1223         # although $INC{"URI/URL.pm"} may have failed. But as
1224         # I really want to say "bla loaded OK", I have to somehow
1225         # cache results.
1226         ### warn "$file in %INC"; #debug
1227         return 1;
1228     } elsif (eval { require $file }) {
1229         # eval is good: if we haven't yet read the database it's
1230         # perfect and if we have installed the module in the meantime,
1231         # it tries again. The second require is only a NOOP returning
1232         # 1 if we had success, otherwise it's retrying
1233
1234         my $v = eval "\$$mod\::VERSION";
1235         $v = $v ? " (v$v)" : "";
1236         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1237         if ($mod eq "CPAN::WAIT") {
1238             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1239         }
1240         return 1;
1241     } elsif ($mod eq "Net::FTP") {
1242         $CPAN::Frontend->mywarn(qq{
1243   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1244   if you just type
1245       install Bundle::libnet
1246
1247 }) unless $Have_warned->{"Net::FTP"}++;
1248         $CPAN::Frontend->mysleep(3);
1249     } elsif ($mod eq "Digest::SHA"){
1250         if ($Have_warned->{"Digest::SHA"}++) {
1251             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1252                                      qq{because Digest::SHA not installed.\n});
1253         } else {
1254             $CPAN::Frontend->mywarn(qq{
1255   CPAN: checksum security checks disabled because Digest::SHA not installed.
1256   Please consider installing the Digest::SHA module.
1257
1258 });
1259             $CPAN::Frontend->mysleep(2);
1260         }
1261     } elsif ($mod eq "Module::Signature"){
1262         # NOT prefs_lookup, we are not a distro
1263         my $check_sigs = $CPAN::Config->{check_sigs};
1264         if (not $check_sigs) {
1265             # they do not want us:-(
1266         } elsif (not $Have_warned->{"Module::Signature"}++) {
1267             # No point in complaining unless the user can
1268             # reasonably install and use it.
1269             if (eval { require Crypt::OpenPGP; 1 } ||
1270                 (
1271                  defined $CPAN::Config->{'gpg'}
1272                  &&
1273                  $CPAN::Config->{'gpg'} =~ /\S/
1274                 )
1275                ) {
1276                 $CPAN::Frontend->mywarn(qq{
1277   CPAN: Module::Signature security checks disabled because Module::Signature
1278   not installed.  Please consider installing the Module::Signature module.
1279   You may also need to be able to connect over the Internet to the public
1280   keyservers like pgp.mit.edu (port 11371).
1281
1282 });
1283                 $CPAN::Frontend->mysleep(2);
1284             }
1285         }
1286     } else {
1287         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1288     }
1289     return 0;
1290 }
1291
1292 #-> sub CPAN::instance ;
1293 sub instance {
1294     my($mgr,$class,$id) = @_;
1295     CPAN::Index->reload;
1296     $id ||= "";
1297     # unsafe meta access, ok?
1298     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1299     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1300 }
1301
1302 #-> sub CPAN::new ;
1303 sub new {
1304     bless {}, shift;
1305 }
1306
1307 #-> sub CPAN::cleanup ;
1308 sub cleanup {
1309   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1310   local $SIG{__DIE__} = '';
1311   my($message) = @_;
1312   my $i = 0;
1313   my $ineval = 0;
1314   my($subroutine);
1315   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1316       $ineval = 1, last if
1317           $subroutine eq '(eval)';
1318   }
1319   return if $ineval && !$CPAN::End;
1320   return unless defined $META->{LOCK};
1321   return unless -f $META->{LOCK};
1322   $META->savehist;
1323   close $META->{LOCKFH};
1324   unlink $META->{LOCK};
1325   # require Carp;
1326   # Carp::cluck("DEBUGGING");
1327   if ( $CPAN::CONFIG_DIRTY ) {
1328       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1329   }
1330   $CPAN::Frontend->myprint("Lockfile removed.\n");
1331 }
1332
1333 #-> sub CPAN::readhist
1334 sub readhist {
1335     my($self,$term,$histfile) = @_;
1336     my($fh) = FileHandle->new;
1337     open $fh, "<$histfile" or last;
1338     local $/ = "\n";
1339     while (<$fh>) {
1340         chomp;
1341         $term->AddHistory($_);
1342     }
1343     close $fh;
1344 }
1345
1346 #-> sub CPAN::savehist
1347 sub savehist {
1348     my($self) = @_;
1349     my($histfile,$histsize);
1350     unless ($histfile = $CPAN::Config->{'histfile'}){
1351         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1352         return;
1353     }
1354     $histsize = $CPAN::Config->{'histsize'} || 100;
1355     if ($CPAN::term){
1356         unless ($CPAN::term->can("GetHistory")) {
1357             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1358             return;
1359         }
1360     } else {
1361         return;
1362     }
1363     my @h = $CPAN::term->GetHistory;
1364     splice @h, 0, @h-$histsize if @h>$histsize;
1365     my($fh) = FileHandle->new;
1366     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1367     local $\ = local $, = "\n";
1368     print $fh @h;
1369     close $fh;
1370 }
1371
1372 #-> sub CPAN::is_tested
1373 sub is_tested {
1374     my($self,$what,$when) = @_;
1375     unless ($what) {
1376         Carp::cluck("DEBUG: empty what");
1377         return;
1378     }
1379     $self->{is_tested}{$what} = $when;
1380 }
1381
1382 #-> sub CPAN::is_installed
1383 # unsets the is_tested flag: as soon as the thing is installed, it is
1384 # not needed in set_perl5lib anymore
1385 sub is_installed {
1386     my($self,$what) = @_;
1387     delete $self->{is_tested}{$what};
1388 }
1389
1390 sub _list_sorted_descending_is_tested {
1391     my($self) = @_;
1392     sort
1393         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1394             keys %{$self->{is_tested}}
1395 }
1396
1397 #-> sub CPAN::set_perl5lib
1398 sub set_perl5lib {
1399     my($self,$for) = @_;
1400     unless ($for) {
1401         (undef,undef,undef,$for) = caller(1);
1402         $for =~ s/.*://;
1403     }
1404     $self->{is_tested} ||= {};
1405     return unless %{$self->{is_tested}};
1406     my $env = $ENV{PERL5LIB};
1407     $env = $ENV{PERLLIB} unless defined $env;
1408     my @env;
1409     push @env, $env if defined $env and length $env;
1410     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1411     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1412
1413     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1414     if (@dirs < 12) {
1415         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1416     } elsif (@dirs < 24) {
1417         my @d = map {my $cp = $_;
1418                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1419                      $cp
1420                  } @dirs;
1421         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1422                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1423                                  "for '$for'\n"
1424                                 );
1425     } else {
1426         my $cnt = keys %{$self->{is_tested}};
1427         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1428                                  "$cnt build dirs to PERL5LIB; ".
1429                                  "for '$for'\n"
1430                                 );
1431     }
1432
1433     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1434 }
1435
1436 package CPAN::CacheMgr;
1437 use strict;
1438
1439 #-> sub CPAN::CacheMgr::as_string ;
1440 sub as_string {
1441     eval { require Data::Dumper };
1442     if ($@) {
1443         return shift->SUPER::as_string;
1444     } else {
1445         return Data::Dumper::Dumper(shift);
1446     }
1447 }
1448
1449 #-> sub CPAN::CacheMgr::cachesize ;
1450 sub cachesize {
1451     shift->{DU};
1452 }
1453
1454 #-> sub CPAN::CacheMgr::tidyup ;
1455 sub tidyup {
1456   my($self) = @_;
1457   return unless $CPAN::META->{LOCK};
1458   return unless -d $self->{ID};
1459   my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
1460   for my $current (0..$#toremove) {
1461     my $toremove = $toremove[$current];
1462     $CPAN::Frontend->myprint(sprintf(
1463                                      "DEL(%d/%d): %s \n",
1464                                      $current+1,
1465                                      scalar @toremove,
1466                                      $toremove,
1467                                     )
1468                             );
1469     return if $CPAN::Signal;
1470     $self->_clean_cache($toremove);
1471     return if $CPAN::Signal;
1472   }
1473 }
1474
1475 #-> sub CPAN::CacheMgr::dir ;
1476 sub dir {
1477     shift->{ID};
1478 }
1479
1480 #-> sub CPAN::CacheMgr::entries ;
1481 sub entries {
1482     my($self,$dir) = @_;
1483     return unless defined $dir;
1484     $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
1485     $dir ||= $self->{ID};
1486     my($cwd) = CPAN::anycwd();
1487     chdir $dir or Carp::croak("Can't chdir to $dir: $!");
1488     my $dh = DirHandle->new(File::Spec->curdir)
1489         or Carp::croak("Couldn't opendir $dir: $!");
1490     my(@entries);
1491     for ($dh->read) {
1492         next if $_ eq "." || $_ eq "..";
1493         if (-f $_) {
1494             push @entries, File::Spec->catfile($dir,$_);
1495         } elsif (-d _) {
1496             push @entries, File::Spec->catdir($dir,$_);
1497         } else {
1498             $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
1499         }
1500     }
1501     chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
1502     sort { -M $a <=> -M $b} @entries;
1503 }
1504
1505 #-> sub CPAN::CacheMgr::disk_usage ;
1506 sub disk_usage {
1507     my($self,$dir,$fast) = @_;
1508     return if exists $self->{SIZE}{$dir};
1509     return if $CPAN::Signal;
1510     my($Du) = 0;
1511     if (-e $dir) {
1512         if (-d $dir) {
1513             unless (-x $dir) {
1514                 unless (chmod 0755, $dir) {
1515                     $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
1516                                             "permission to change the permission; cannot ".
1517                                             "estimate disk usage of '$dir'\n");
1518                     $CPAN::Frontend->mysleep(5);
1519                     return;
1520                 }
1521             }
1522         } elsif (-f $dir) {
1523             # nothing to say, no matter what the permissions
1524         }
1525     } else {
1526         $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
1527         return;
1528     }
1529     if ($fast) {
1530         $Du = 0; # placeholder
1531     } else {
1532         find(
1533              sub {
1534            $File::Find::prune++ if $CPAN::Signal;
1535            return if -l $_;
1536            if ($^O eq 'MacOS') {
1537              require Mac::Files;
1538              my $cat  = Mac::Files::FSpGetCatInfo($_);
1539              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1540            } else {
1541              if (-d _) {
1542                unless (-x _) {
1543                  unless (chmod 0755, $_) {
1544                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1545                                            "the permission to change the permission; ".
1546                                            "can only partially estimate disk usage ".
1547                                            "of '$_'\n");
1548                    $CPAN::Frontend->mysleep(5);
1549                    return;
1550                  }
1551                }
1552              } else {
1553                $Du += (-s _);
1554              }
1555            }
1556          },
1557          $dir
1558             );
1559     }
1560     return if $CPAN::Signal;
1561     $self->{SIZE}{$dir} = $Du/1024/1024;
1562     unshift @{$self->{FIFO}}, $dir;
1563     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1564     $self->{DU} += $Du/1024/1024;
1565     $self->{DU};
1566 }
1567
1568 #-> sub CPAN::CacheMgr::_clean_cache ;
1569 sub _clean_cache {
1570     my($self,$dir) = @_;
1571     return unless -e $dir;
1572     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1573             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1574         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1575                                 "will not remove\n");
1576         $CPAN::Frontend->mysleep(5);
1577         return;
1578     }
1579     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1580         if $CPAN::DEBUG;
1581     File::Path::rmtree($dir);
1582     my $id_deleted = 0;
1583     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1584         my $yaml_module = CPAN::_yaml_module;
1585         if ($CPAN::META->has_inst($yaml_module)) {
1586             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1587             if ($@) {
1588                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1589                 unlink "$dir.yml" or
1590                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1591                 return;
1592             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1593                 $CPAN::META->delete("CPAN::Distribution", $id);
1594
1595                 # XXX we should restore the state NOW, otherise this
1596                 # distro does not exist until we read an index. BUG ALERT(?)
1597
1598                 # $CPAN::Frontend->mywarn (" +++\n");
1599                 $id_deleted++;
1600             }
1601         }
1602         unlink "$dir.yml"; # may fail
1603         unless ($id_deleted) {
1604             CPAN->debug("no distro found associated with '$dir'");
1605         }
1606     }
1607     $self->{DU} -= $self->{SIZE}{$dir};
1608     delete $self->{SIZE}{$dir};
1609 }
1610
1611 #-> sub CPAN::CacheMgr::new ;
1612 sub new {
1613     my $class = shift;
1614     my $time = time;
1615     my($debug,$t2);
1616     $debug = "";
1617     my $self = {
1618                 ID => $CPAN::Config->{build_dir},
1619                 MAX => $CPAN::Config->{'build_cache'},
1620                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1621                 DU => 0
1622                };
1623     File::Path::mkpath($self->{ID});
1624     my $dh = DirHandle->new($self->{ID});
1625     bless $self, $class;
1626     $self->scan_cache;
1627     $t2 = time;
1628     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1629     $time = $t2;
1630     CPAN->debug($debug) if $CPAN::DEBUG;
1631     $self;
1632 }
1633
1634 #-> sub CPAN::CacheMgr::scan_cache ;
1635 sub scan_cache {
1636     my $self = shift;
1637     return if $self->{SCAN} eq 'never';
1638     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1639         unless $self->{SCAN} eq 'atstart';
1640     return unless $CPAN::META->{LOCK};
1641     $CPAN::Frontend->myprint(
1642                              sprintf("Scanning cache %s for sizes\n",
1643                                      $self->{ID}));
1644     my $e;
1645     my @entries = $self->entries($self->{ID});
1646     my $i = 0;
1647     my $painted = 0;
1648     for $e (@entries) {
1649         my $symbol = ".";
1650         if ($self->{DU} > $self->{MAX}) {
1651             $symbol = "-";
1652             $self->disk_usage($e,1);
1653         } else {
1654             $self->disk_usage($e);
1655         }
1656         $i++;
1657         while (($painted/76) < ($i/@entries)) {
1658             $CPAN::Frontend->myprint($symbol);
1659             $painted++;
1660         }
1661         return if $CPAN::Signal;
1662     }
1663     $CPAN::Frontend->myprint("DONE\n");
1664     $self->tidyup;
1665 }
1666
1667 package CPAN::Shell;
1668 use strict;
1669
1670 #-> sub CPAN::Shell::h ;
1671 sub h {
1672     my($class,$about) = @_;
1673     if (defined $about) {
1674         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1675     } else {
1676         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1677         $CPAN::Frontend->myprint(qq{
1678 Display Information $filler (ver $CPAN::VERSION)
1679  command  argument          description
1680  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1681  i        WORD or /REGEXP/  about any of the above
1682  ls       AUTHOR or GLOB    about files in the author's directory
1683     (with WORD being a module, bundle or author name or a distribution
1684     name of the form AUTHOR/DISTRIBUTION)
1685
1686 Download, Test, Make, Install...
1687  get      download                     clean    make clean
1688  make     make (implies get)           look     open subshell in dist directory
1689  test     make test (implies make)     readme   display these README files
1690  install  make install (implies test)  perldoc  display POD documentation
1691
1692 Upgrade
1693  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1694  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1695
1696 Pragmas
1697  force  CMD    try hard to do command  fforce CMD    try harder
1698  notest CMD    skip testing
1699
1700 Other
1701  h,?           display this menu       ! perl-code   eval a perl command
1702  o conf [opt]  set and query options   q             quit the cpan shell
1703  reload cpan   load CPAN.pm again      reload index  load newer indices
1704  autobundle    Snapshot                recent        latest CPAN uploads});
1705 }
1706 }
1707
1708 *help = \&h;
1709
1710 #-> sub CPAN::Shell::a ;
1711 sub a {
1712   my($self,@arg) = @_;
1713   # authors are always UPPERCASE
1714   for (@arg) {
1715     $_ = uc $_ unless /=/;
1716   }
1717   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1718 }
1719
1720 #-> sub CPAN::Shell::globls ;
1721 sub globls {
1722     my($self,$s,$pragmas) = @_;
1723     # ls is really very different, but we had it once as an ordinary
1724     # command in the Shell (upto rev. 321) and we could not handle
1725     # force well then
1726     my(@accept,@preexpand);
1727     if ($s =~ /[\*\?\/]/) {
1728         if ($CPAN::META->has_inst("Text::Glob")) {
1729             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1730                 my $rau = Text::Glob::glob_to_regex(uc $au);
1731                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1732                       if $CPAN::DEBUG;
1733                 push @preexpand, map { $_->id . "/" . $pathglob }
1734                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1735             } else {
1736                 my $rau = Text::Glob::glob_to_regex(uc $s);
1737                 push @preexpand, map { $_->id }
1738                     CPAN::Shell->expand_by_method('CPAN::Author',
1739                                                   ['id'],
1740                                                   "/$rau/");
1741             }
1742         } else {
1743             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1744         }
1745     } else {
1746         push @preexpand, uc $s;
1747     }
1748     for (@preexpand) {
1749         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1750             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1751             next;
1752         }
1753         push @accept, $_;
1754     }
1755     my $silent = @accept>1;
1756     my $last_alpha = "";
1757     my @results;
1758     for my $a (@accept){
1759         my($author,$pathglob);
1760         if ($a =~ m|(.*?)/(.*)|) {
1761             my $a2 = $1;
1762             $pathglob = $2;
1763             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1764                                                     ['id'],
1765                                                     $a2)
1766                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1767         } else {
1768             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1769                                                     ['id'],
1770                                                     $a)
1771                 or $CPAN::Frontend->mydie("No author found for $a\n");
1772         }
1773         if ($silent) {
1774             my $alpha = substr $author->id, 0, 1;
1775             my $ad;
1776             if ($alpha eq $last_alpha) {
1777                 $ad = "";
1778             } else {
1779                 $ad = "[$alpha]";
1780                 $last_alpha = $alpha;
1781             }
1782             $CPAN::Frontend->myprint($ad);
1783         }
1784         for my $pragma (@$pragmas) {
1785             if ($author->can($pragma)) {
1786                 $author->$pragma();
1787             }
1788         }
1789         push @results, $author->ls($pathglob,$silent); # silent if
1790                                                        # more than one
1791                                                        # author
1792         for my $pragma (@$pragmas) {
1793             my $unpragma = "un$pragma";
1794             if ($author->can($unpragma)) {
1795                 $author->$unpragma();
1796             }
1797         }
1798     }
1799     @results;
1800 }
1801
1802 #-> sub CPAN::Shell::local_bundles ;
1803 sub local_bundles {
1804     my($self,@which) = @_;
1805     my($incdir,$bdir,$dh);
1806     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1807         my @bbase = "Bundle";
1808         while (my $bbase = shift @bbase) {
1809             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1810             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1811             if ($dh = DirHandle->new($bdir)) { # may fail
1812                 my($entry);
1813                 for $entry ($dh->read) {
1814                     next if $entry =~ /^\./;
1815                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1816                     if (-d File::Spec->catdir($bdir,$entry)){
1817                         push @bbase, "$bbase\::$entry";
1818                     } else {
1819                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1820                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1821                     }
1822                 }
1823             }
1824         }
1825     }
1826 }
1827
1828 #-> sub CPAN::Shell::b ;
1829 sub b {
1830     my($self,@which) = @_;
1831     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1832     $self->local_bundles;
1833     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1834 }
1835
1836 #-> sub CPAN::Shell::d ;
1837 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1838
1839 #-> sub CPAN::Shell::m ;
1840 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1841     my $self = shift;
1842     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1843 }
1844
1845 #-> sub CPAN::Shell::i ;
1846 sub i {
1847     my($self) = shift;
1848     my(@args) = @_;
1849     @args = '/./' unless @args;
1850     my(@result);
1851     for my $type (qw/Bundle Distribution Module/) {
1852         push @result, $self->expand($type,@args);
1853     }
1854     # Authors are always uppercase.
1855     push @result, $self->expand("Author", map { uc $_ } @args);
1856
1857     my $result = @result == 1 ?
1858         $result[0]->as_string :
1859             @result == 0 ?
1860                 "No objects found of any type for argument @args\n" :
1861                     join("",
1862                          (map {$_->as_glimpse} @result),
1863                          scalar @result, " items found\n",
1864                         );
1865     $CPAN::Frontend->myprint($result);
1866 }
1867
1868 #-> sub CPAN::Shell::o ;
1869
1870 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1871 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1872 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1873 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1874 sub o {
1875     my($self,$o_type,@o_what) = @_;
1876     $o_type ||= "";
1877     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1878     if ($o_type eq 'conf') {
1879         if (!@o_what) { # print all things, "o conf"
1880             my($k,$v);
1881             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1882             my @from;
1883             if (exists $INC{'CPAN/Config.pm'}) {
1884                 push @from, $INC{'CPAN/Config.pm'};
1885             }
1886             if (exists $INC{'CPAN/MyConfig.pm'}) {
1887                 push @from, $INC{'CPAN/MyConfig.pm'};
1888             }
1889             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1890             $CPAN::Frontend->myprint(":\n");
1891             for $k (sort keys %CPAN::HandleConfig::can) {
1892                 $v = $CPAN::HandleConfig::can{$k};
1893                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1894             }
1895             $CPAN::Frontend->myprint("\n");
1896             for $k (sort keys %$CPAN::Config) {
1897                 CPAN::HandleConfig->prettyprint($k);
1898             }
1899             $CPAN::Frontend->myprint("\n");
1900         } else {
1901             if (CPAN::HandleConfig->edit(@o_what)) {
1902             } else {
1903                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1904                                          qq{items\n\n});
1905             }
1906         }
1907     } elsif ($o_type eq 'debug') {
1908         my(%valid);
1909         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1910         if (@o_what) {
1911             while (@o_what) {
1912                 my($what) = shift @o_what;
1913                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1914                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1915                     next;
1916                 }
1917                 if ( exists $CPAN::DEBUG{$what} ) {
1918                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1919                 } elsif ($what =~ /^\d/) {
1920                     $CPAN::DEBUG = $what;
1921                 } elsif (lc $what eq 'all') {
1922                     my($max) = 0;
1923                     for (values %CPAN::DEBUG) {
1924                         $max += $_;
1925                     }
1926                     $CPAN::DEBUG = $max;
1927                 } else {
1928                     my($known) = 0;
1929                     for (keys %CPAN::DEBUG) {
1930                         next unless lc($_) eq lc($what);
1931                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1932                         $known = 1;
1933                     }
1934                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1935                         unless $known;
1936                 }
1937             }
1938         } else {
1939           my $raw = "Valid options for debug are ".
1940               join(", ",sort(keys %CPAN::DEBUG), 'all').
1941                   qq{ or a number. Completion works on the options. }.
1942                       qq{Case is ignored.};
1943           require Text::Wrap;
1944           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1945           $CPAN::Frontend->myprint("\n\n");
1946         }
1947         if ($CPAN::DEBUG) {
1948             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1949             my($k,$v);
1950             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1951                 $v = $CPAN::DEBUG{$k};
1952                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1953                     if $v & $CPAN::DEBUG;
1954             }
1955         } else {
1956             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1957         }
1958     } else {
1959         $CPAN::Frontend->myprint(qq{
1960 Known options:
1961   conf    set or get configuration variables
1962   debug   set or get debugging options
1963 });
1964     }
1965 }
1966
1967 # CPAN::Shell::paintdots_onreload
1968 sub paintdots_onreload {
1969     my($ref) = shift;
1970     sub {
1971         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1972             my($subr) = $1;
1973             ++$$ref;
1974             local($|) = 1;
1975             # $CPAN::Frontend->myprint(".($subr)");
1976             $CPAN::Frontend->myprint(".");
1977             if ($subr =~ /\bshell\b/i) {
1978                 # warn "debug[$_[0]]";
1979
1980                 # It would be nice if we could detect that a
1981                 # subroutine has actually changed, but for now we
1982                 # practically always set the GOTOSHELL global
1983
1984                 $CPAN::GOTOSHELL=1;
1985             }
1986             return;
1987         }
1988         warn @_;
1989     };
1990 }
1991
1992 #-> sub CPAN::Shell::hosts ;
1993 sub hosts {
1994     my($self) = @_;
1995     my $fullstats = CPAN::FTP->_ftp_statistics();
1996     my $history = $fullstats->{history} || [];
1997     my %S; # statistics
1998     while (my $last = pop @$history) {
1999         my $attempts = $last->{attempts} or next;
2000         my $start;
2001         if (@$attempts) {
2002             $start = $attempts->[-1]{start};
2003             if ($#$attempts > 0) {
2004                 for my $i (0..$#$attempts-1) {
2005                     my $url = $attempts->[$i]{url} or next;
2006                     $S{no}{$url}++;
2007                 }
2008             }
2009         } else {
2010             $start = $last->{start};
2011         }
2012         next unless $last->{thesiteurl}; # C-C? bad filenames?
2013         $S{start} = $start;
2014         $S{end} ||= $last->{end};
2015         my $dltime = $last->{end} - $start;
2016         my $dlsize = $last->{filesize} || 0;
2017         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2018         my $s = $S{ok}{$url} ||= {};
2019         $s->{n}++;
2020         $s->{dlsize} ||= 0;
2021         $s->{dlsize} += $dlsize/1024;
2022         $s->{dltime} ||= 0;
2023         $s->{dltime} += $dltime;
2024     }
2025     my $res;
2026     for my $url (keys %{$S{ok}}) {
2027         next if $S{ok}{$url}{dltime} == 0; # div by zero
2028         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2029                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2030                              $url,
2031                             ];
2032     }
2033     for my $url (keys %{$S{no}}) {
2034         push @{$res->{no}}, [$S{no}{$url},
2035                              $url,
2036                             ];
2037     }
2038     my $R = ""; # report
2039     if ($S{start} && $S{end}) {
2040         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2041         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2042     }
2043     if ($res->{ok} && @{$res->{ok}}) {
2044         $R .= sprintf "\nSuccessful downloads:
2045    N       kB  secs      kB/s url\n";
2046         my $i = 20;
2047         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2048             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2049             last if --$i<=0;
2050         }
2051     }
2052     if ($res->{no} && @{$res->{no}}) {
2053         $R .= sprintf "\nUnsuccessful downloads:\n";
2054         my $i = 20;
2055         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2056             $R .= sprintf "%4d %s\n", @$_;
2057             last if --$i<=0;
2058         }
2059     }
2060     $CPAN::Frontend->myprint($R);
2061 }
2062
2063 #-> sub CPAN::Shell::reload ;
2064 sub reload {
2065     my($self,$command,@arg) = @_;
2066     $command ||= "";
2067     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2068     if ($command =~ /^cpan$/i) {
2069         my $redef = 0;
2070         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2071         my $failed;
2072         my @relo = (
2073                     "CPAN.pm",
2074                     "CPAN/Debug.pm",
2075                     "CPAN/FirstTime.pm",
2076                     "CPAN/HandleConfig.pm",
2077                     "CPAN/Kwalify.pm",
2078                     "CPAN/Queue.pm",
2079                     "CPAN/Reporter.pm",
2080                     "CPAN/SQLite.pm",
2081                     "CPAN/Tarzip.pm",
2082                     "CPAN/Version.pm",
2083                    );
2084       MFILE: for my $f (@relo) {
2085             next unless exists $INC{$f};
2086             my $p = $f;
2087             $p =~ s/\.pm$//;
2088             $p =~ s|/|::|g;
2089             $CPAN::Frontend->myprint("($p");
2090             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2091             $self->_reload_this($f) or $failed++;
2092             my $v = eval "$p\::->VERSION";
2093             $CPAN::Frontend->myprint("v$v)");
2094         }
2095         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2096         if ($failed) {
2097             my $errors = $failed == 1 ? "error" : "errors";
2098             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2099                                     "this session.\n");
2100         }
2101     } elsif ($command =~ /^index$/i) {
2102       CPAN::Index->force_reload;
2103     } else {
2104       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2105 index    re-reads the index files\n});
2106     }
2107 }
2108
2109 # reload means only load again what we have loaded before
2110 #-> sub CPAN::Shell::_reload_this ;
2111 sub _reload_this {
2112     my($self,$f,$args) = @_;
2113     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2114     return 1 unless $INC{$f}; # we never loaded this, so we do not
2115                               # reload but say OK
2116     my $pwd = CPAN::anycwd();
2117     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2118     my($file);
2119     for my $inc (@INC) {
2120         $file = File::Spec->catfile($inc,split /\//, $f);
2121         last if -f $file;
2122         $file = "";
2123     }
2124     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2125     my @inc = @INC;
2126     unless ($file && -f $file) {
2127         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2128         $file = $INC{$f};
2129         unless (CPAN->has_inst("File::Basename")) {
2130             @inc = File::Basename::dirname($file);
2131         } else {
2132             # do we ever need this?
2133             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2134         }
2135     }
2136     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2137     unless (-f $file) {
2138         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2139         return;
2140     }
2141     my $mtime = (stat $file)[9];
2142     $reload->{$f} ||= $^T;
2143     my $must_reload = $mtime > $reload->{$f};
2144     $args ||= {};
2145     $must_reload ||= $args->{reloforce};
2146     if ($must_reload) {
2147         my $fh = FileHandle->new($file) or
2148             $CPAN::Frontend->mydie("Could not open $file: $!");
2149         local($/);
2150         local $^W = 1;
2151         my $content = <$fh>;
2152         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2153             if $CPAN::DEBUG;
2154         delete $INC{$f};
2155         local @INC = @inc;
2156         eval "require '$f'";
2157         if ($@){
2158             warn $@;
2159             return;
2160         }
2161         $reload->{$f} = time;
2162     } else {
2163         $CPAN::Frontend->myprint("__unchanged__");
2164     }
2165     return 1;
2166 }
2167
2168 #-> sub CPAN::Shell::mkmyconfig ;
2169 sub mkmyconfig {
2170     my($self, $cpanpm, %args) = @_;
2171     require CPAN::FirstTime;
2172     my $home = CPAN::HandleConfig::home;
2173     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2174         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2175     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2176     CPAN::HandleConfig::require_myconfig_or_config;
2177     $CPAN::Config ||= {};
2178     $CPAN::Config = {
2179         %$CPAN::Config,
2180         build_dir           =>  undef,
2181         cpan_home           =>  undef,
2182         keep_source_where   =>  undef,
2183         histfile            =>  undef,
2184     };
2185     CPAN::FirstTime::init($cpanpm, %args);
2186 }
2187
2188 #-> sub CPAN::Shell::_binary_extensions ;
2189 sub _binary_extensions {
2190     my($self) = shift @_;
2191     my(@result,$module,%seen,%need,$headerdone);
2192     for $module ($self->expand('Module','/./')) {
2193         my $file  = $module->cpan_file;
2194         next if $file eq "N/A";
2195         next if $file =~ /^Contact Author/;
2196         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2197         next if $dist->isa_perl;
2198         next unless $module->xs_file;
2199         local($|) = 1;
2200         $CPAN::Frontend->myprint(".");
2201         push @result, $module;
2202     }
2203 #    print join " | ", @result;
2204     $CPAN::Frontend->myprint("\n");
2205     return @result;
2206 }
2207
2208 #-> sub CPAN::Shell::recompile ;
2209 sub recompile {
2210     my($self) = shift @_;
2211     my($module,@module,$cpan_file,%dist);
2212     @module = $self->_binary_extensions();
2213     for $module (@module){  # we force now and compile later, so we
2214                             # don't do it twice
2215         $cpan_file = $module->cpan_file;
2216         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2217         $pack->force; #
2218         $dist{$cpan_file}++;
2219     }
2220     for $cpan_file (sort keys %dist) {
2221         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2222         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2223         $pack->install;
2224         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2225                            # stop a package from recompiling,
2226                            # e.g. IO-1.12 when we have perl5.003_10
2227     }
2228 }
2229
2230 #-> sub CPAN::Shell::scripts ;
2231 sub scripts {
2232     my($self, $arg) = @_;
2233     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2234
2235     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2236         unless ($CPAN::META->has_inst($req)) {
2237             $CPAN::Frontend->mywarn("  $req not available\n");
2238         }
2239     }
2240     my $p = HTML::LinkExtor->new();
2241     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2242     unless (-f $indexfile) {
2243         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2244     }
2245     $p->parse_file($indexfile);
2246     my @hrefs;
2247     my $qrarg;
2248     if ($arg =~ s|^/(.+)/$|$1|) {
2249         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2250     }
2251     for my $l ($p->links) {
2252         my $tag = shift @$l;
2253         next unless $tag eq "a";
2254         my %att = @$l;
2255         my $href = $att{href};
2256         next unless $href =~ s|^\.\./authors/id/./../||;
2257         if ($arg) {
2258             if ($qrarg) {
2259                 if ($href =~ $qrarg) {
2260                     push @hrefs, $href;
2261                 }
2262             } else {
2263                 if ($href =~ /\Q$arg\E/) {
2264                     push @hrefs, $href;
2265                 }
2266             }
2267         } else {
2268             push @hrefs, $href;
2269         }
2270     }
2271     # now filter for the latest version if there is more than one of a name
2272     my %stems;
2273     for (sort @hrefs) {
2274         my $href = $_;
2275         s/-v?\d.*//;
2276         my $stem = $_;
2277         $stems{$stem} ||= [];
2278         push @{$stems{$stem}}, $href;
2279     }
2280     for (sort keys %stems) {
2281         my $highest;
2282         if (@{$stems{$_}} > 1) {
2283             $highest = List::Util::reduce {
2284                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2285               } @{$stems{$_}};
2286         } else {
2287             $highest = $stems{$_}[0];
2288         }
2289         $CPAN::Frontend->myprint("$highest\n");
2290     }
2291 }
2292
2293 #-> sub CPAN::Shell::report ;
2294 sub report {
2295     my($self,@args) = @_;
2296     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2297         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2298     }
2299     local $CPAN::Config->{test_report} = 1;
2300     $self->force("test",@args); # force is there so that the test be
2301                                 # re-run (as documented)
2302 }
2303
2304 # compare with is_tested
2305 #-> sub CPAN::Shell::install_tested
2306 sub install_tested {
2307     my($self,@some) = @_;
2308     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2309         return if @some;
2310     CPAN::Index->reload;
2311
2312     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2313         my $yaml = "$b.yml";
2314         unless (-f $yaml){
2315             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2316             next;
2317         }
2318         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2319         my $id = $yaml_content->[0]{distribution}{ID};
2320         unless ($id){
2321             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2322             next;
2323         }
2324         my $do = CPAN::Shell->expandany($id);
2325         unless ($do){
2326             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2327             next;
2328         }
2329         unless ($do->{build_dir}) {
2330             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2331             next;
2332         }
2333         unless ($do->{build_dir} eq $b) {
2334             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2335             next;
2336         }
2337         push @some, $do;
2338     }
2339
2340     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2341         return unless @some;
2342
2343     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2344     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2345         return unless @some;
2346
2347     # @some = grep { not $_->uptodate } @some;
2348     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2349     #     return unless @some;
2350
2351     CPAN->debug("some[@some]");
2352     for my $d (@some) {
2353         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2354         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2355         $CPAN::Frontend->mysleep(1);
2356         $self->install($d);
2357     }
2358 }
2359
2360 #-> sub CPAN::Shell::upgrade ;
2361 sub upgrade {
2362     my($self,@args) = @_;
2363     $self->install($self->r(@args));
2364 }
2365
2366 #-> sub CPAN::Shell::_u_r_common ;
2367 sub _u_r_common {
2368     my($self) = shift @_;
2369     my($what) = shift @_;
2370     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2371     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2372           $what && $what =~ /^[aru]$/;
2373     my(@args) = @_;
2374     @args = '/./' unless @args;
2375     my(@result,$module,%seen,%need,$headerdone,
2376        $version_undefs,$version_zeroes);
2377     $version_undefs = $version_zeroes = 0;
2378     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2379     my @expand = $self->expand('Module',@args);
2380     my $expand = scalar @expand;
2381     if (0) { # Looks like noise to me, was very useful for debugging
2382              # for metadata cache
2383         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2384     }
2385   MODULE: for $module (@expand) {
2386         my $file  = $module->cpan_file;
2387         next MODULE unless defined $file; # ??
2388         $file =~ s|^./../||;
2389         my($latest) = $module->cpan_version;
2390         my($inst_file) = $module->inst_file;
2391         my($have);
2392         return if $CPAN::Signal;
2393         if ($inst_file){
2394             if ($what eq "a") {
2395                 $have = $module->inst_version;
2396             } elsif ($what eq "r") {
2397                 $have = $module->inst_version;
2398                 local($^W) = 0;
2399                 if ($have eq "undef"){
2400                     $version_undefs++;
2401                 } elsif ($have == 0){
2402                     $version_zeroes++;
2403                 }
2404                 next MODULE unless CPAN::Version->vgt($latest, $have);
2405 # to be pedantic we should probably say:
2406 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2407 # to catch the case where CPAN has a version 0 and we have a version undef
2408             } elsif ($what eq "u") {
2409                 next MODULE;
2410             }
2411         } else {
2412             if ($what eq "a") {
2413                 next MODULE;
2414             } elsif ($what eq "r") {
2415                 next MODULE;
2416             } elsif ($what eq "u") {
2417                 $have = "-";
2418             }
2419         }
2420         return if $CPAN::Signal; # this is sometimes lengthy
2421         $seen{$file} ||= 0;
2422         if ($what eq "a") {
2423             push @result, sprintf "%s %s\n", $module->id, $have;
2424         } elsif ($what eq "r") {
2425             push @result, $module->id;
2426             next MODULE if $seen{$file}++;
2427         } elsif ($what eq "u") {
2428             push @result, $module->id;
2429             next MODULE if $seen{$file}++;
2430             next MODULE if $file =~ /^Contact/;
2431         }
2432         unless ($headerdone++){
2433             $CPAN::Frontend->myprint("\n");
2434             $CPAN::Frontend->myprint(sprintf(
2435                                              $sprintf,
2436                                              "",
2437                                              "Package namespace",
2438                                              "",
2439                                              "installed",
2440                                              "latest",
2441                                              "in CPAN file"
2442                                             ));
2443         }
2444         my $color_on = "";
2445         my $color_off = "";
2446         if (
2447             $COLOR_REGISTERED
2448             &&
2449             $CPAN::META->has_inst("Term::ANSIColor")
2450             &&
2451             $module->description
2452            ) {
2453             $color_on = Term::ANSIColor::color("green");
2454             $color_off = Term::ANSIColor::color("reset");
2455         }
2456         $CPAN::Frontend->myprint(sprintf $sprintf,
2457                                  $color_on,
2458                                  $module->id,
2459                                  $color_off,
2460                                  $have,
2461                                  $latest,
2462                                  $file);
2463         $need{$module->id}++;
2464     }
2465     unless (%need) {
2466         if ($what eq "u") {
2467             $CPAN::Frontend->myprint("No modules found for @args\n");
2468         } elsif ($what eq "r") {
2469             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2470         }
2471     }
2472     if ($what eq "r") {
2473         if ($version_zeroes) {
2474             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2475             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2476                 qq{a version number of 0\n});
2477         }
2478         if ($version_undefs) {
2479             my $s_has = $version_undefs > 1 ? "s have" : " has";
2480             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2481                 qq{parseable version number\n});
2482         }
2483     }
2484     @result;
2485 }
2486
2487 #-> sub CPAN::Shell::r ;
2488 sub r {
2489     shift->_u_r_common("r",@_);
2490 }
2491
2492 #-> sub CPAN::Shell::u ;
2493 sub u {
2494     shift->_u_r_common("u",@_);
2495 }
2496
2497 #-> sub CPAN::Shell::failed ;
2498 sub failed {
2499     my($self,$only_id,$silent) = @_;
2500     my @failed;
2501   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2502         my $failed = "";
2503       NAY: for my $nosayer ( # order matters!
2504                             "unwrapped",
2505                             "writemakefile",
2506                             "signature_verify",
2507                             "make",
2508                             "make_test",
2509                             "install",
2510                             "make_clean",
2511                            ) {
2512             next unless exists $d->{$nosayer};
2513             next unless defined $d->{$nosayer};
2514             next unless (
2515                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2516                          $d->{$nosayer}->failed :
2517                          $d->{$nosayer} =~ /^NO/
2518                         );
2519             next NAY if $only_id && $only_id != (
2520                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2521                                                  ?
2522                                                  $d->{$nosayer}->commandid
2523                                                  :
2524                                                  $CPAN::CurrentCommandId
2525                                                 );
2526             $failed = $nosayer;
2527             last;
2528         }
2529         next DIST unless $failed;
2530         my $id = $d->id;
2531         $id =~ s|^./../||;
2532         #$print .= sprintf(
2533         #                  "  %-45s: %s %s\n",
2534         push @failed,
2535             (
2536              UNIVERSAL::can($d->{$failed},"failed") ?
2537              [
2538               $d->{$failed}->commandid,
2539               $id,
2540               $failed,
2541               $d->{$failed}->text,
2542               $d->{$failed}{TIME}||0,
2543              ] :
2544              [
2545               1,
2546               $id,
2547               $failed,
2548               $d->{$failed},
2549               0,
2550              ]
2551             );
2552     }
2553     my $scope;
2554     if ($only_id) {
2555         $scope = "this command";
2556     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2557         $scope = "this or a previous session";
2558         # it might be nice to have a section for previous session and
2559         # a second for this
2560     } else {
2561         $scope = "this session";
2562     }
2563     if (@failed) {
2564         my $print;
2565         my $debug = 0;
2566         if ($debug) {
2567             $print = join "",
2568                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2569                     sort { $a->[0] <=> $b->[0] } @failed;
2570         } else {
2571             $print = join "",
2572                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2573                     sort {
2574                         $a->[0] <=> $b->[0]
2575                             ||
2576                                 $a->[4] <=> $b->[4]
2577                        } @failed;
2578         }
2579         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2580     } elsif (!$only_id || !$silent) {
2581         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2582     }
2583 }
2584
2585 # XXX intentionally undocumented because completely bogus, unportable,
2586 # useless, etc.
2587
2588 #-> sub CPAN::Shell::status ;
2589 sub status {
2590     my($self) = @_;
2591     require Devel::Size;
2592     my $ps = FileHandle->new;
2593     open $ps, "/proc/$$/status";
2594     my $vm = 0;
2595     while (<$ps>) {
2596         next unless /VmSize:\s+(\d+)/;
2597         $vm = $1;
2598         last;
2599     }
2600     $CPAN::Frontend->mywarn(sprintf(
2601                                     "%-27s %6d\n%-27s %6d\n",
2602                                     "vm",
2603                                     $vm,
2604                                     "CPAN::META",
2605                                     Devel::Size::total_size($CPAN::META)/1024,
2606                                    ));
2607     for my $k (sort keys %$CPAN::META) {
2608         next unless substr($k,0,4) eq "read";
2609         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2610         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2611             warn sprintf "  %-25s %6d (keys: %6d)\n",
2612                 $k2,
2613                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2614                           scalar keys %{$CPAN::META->{$k}{$k2}};
2615         }
2616     }
2617 }
2618
2619 # compare with install_tested
2620 #-> sub CPAN::Shell::is_tested
2621 sub is_tested {
2622     my($self) = @_;
2623     CPAN::Index->reload;
2624     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2625         my $time;
2626         if ($CPAN::META->{is_tested}{$b}) {
2627             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2628         } else {
2629             $time = scalar localtime;
2630             $time =~ s/\S/?/g;
2631         }
2632         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2633     }
2634 }
2635
2636 #-> sub CPAN::Shell::autobundle ;
2637 sub autobundle {
2638     my($self) = shift;
2639     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2640     my(@bundle) = $self->_u_r_common("a",@_);
2641     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2642     File::Path::mkpath($todir);
2643     unless (-d $todir) {
2644         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2645         return;
2646     }
2647     my($y,$m,$d) =  (localtime)[5,4,3];
2648     $y+=1900;
2649     $m++;
2650     my($c) = 0;
2651     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2652     my($to) = File::Spec->catfile($todir,"$me.pm");
2653     while (-f $to) {
2654         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2655         $to = File::Spec->catfile($todir,"$me.pm");
2656     }
2657     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2658     $fh->print(
2659                "package Bundle::$me;\n\n",
2660                "\$VERSION = '0.01';\n\n",
2661                "1;\n\n",
2662                "__END__\n\n",
2663                "=head1 NAME\n\n",
2664                "Bundle::$me - Snapshot of installation on ",
2665                $Config::Config{'myhostname'},
2666                " on ",
2667                scalar(localtime),
2668                "\n\n=head1 SYNOPSIS\n\n",
2669                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2670                "=head1 CONTENTS\n\n",
2671                join("\n", @bundle),
2672                "\n\n=head1 CONFIGURATION\n\n",
2673                Config->myconfig,
2674                "\n\n=head1 AUTHOR\n\n",
2675                "This Bundle has been generated automatically ",
2676                "by the autobundle routine in CPAN.pm.\n",
2677               );
2678     $fh->close;
2679     $CPAN::Frontend->myprint("\nWrote bundle file
2680     $to\n\n");
2681 }
2682
2683 #-> sub CPAN::Shell::expandany ;
2684 sub expandany {
2685     my($self,$s) = @_;
2686     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2687     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2688         $s = CPAN::Distribution->normalize($s);
2689         return $CPAN::META->instance('CPAN::Distribution',$s);
2690         # Distributions spring into existence, not expand
2691     } elsif ($s =~ m|^Bundle::|) {
2692         $self->local_bundles; # scanning so late for bundles seems
2693                               # both attractive and crumpy: always
2694                               # current state but easy to forget
2695                               # somewhere
2696         return $self->expand('Bundle',$s);
2697     } else {
2698         return $self->expand('Module',$s)
2699             if $CPAN::META->exists('CPAN::Module',$s);
2700     }
2701     return;
2702 }
2703
2704 #-> sub CPAN::Shell::expand ;
2705 sub expand {
2706     my $self = shift;
2707     my($type,@args) = @_;
2708     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2709     my $class = "CPAN::$type";
2710     my $methods = ['id'];
2711     for my $meth (qw(name)) {
2712         next unless $class->can($meth);
2713         push @$methods, $meth;
2714     }
2715     $self->expand_by_method($class,$methods,@args);
2716 }
2717
2718 #-> sub CPAN::Shell::expand_by_method ;
2719 sub expand_by_method {
2720     my $self = shift;
2721     my($class,$methods,@args) = @_;
2722     my($arg,@m);
2723     for $arg (@args) {
2724         my($regex,$command);
2725         if ($arg =~ m|^/(.*)/$|) {
2726             $regex = $1;
2727         } elsif ($arg =~ m/=/) {
2728             $command = 1;
2729         }
2730         my $obj;
2731         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2732                     $class,
2733                     defined $regex ? $regex : "UNDEFINED",
2734                     defined $command ? $command : "UNDEFINED",
2735                    ) if $CPAN::DEBUG;
2736         if (defined $regex) {
2737             if (CPAN::_sqlite_running) {
2738                 $CPAN::SQLite->search($class, $regex);
2739             }
2740             for $obj (
2741                       $CPAN::META->all_objects($class)
2742                      ) {
2743                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2744                     # BUG, we got an empty object somewhere
2745                     require Data::Dumper;
2746                     CPAN->debug(sprintf(
2747                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2748                                         $obj,
2749                                         Data::Dumper::Dumper($obj)
2750                                        )) if $CPAN::DEBUG;
2751                     next;
2752                 }
2753                 for my $method (@$methods) {
2754                     my $match = eval {$obj->$method() =~ /$regex/i};
2755                     if ($@) {
2756                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2757                         $err ||= $@; # if we were too restrictive above
2758                         $CPAN::Frontend->mydie("$err\n");
2759                     } elsif ($match) {
2760                         push @m, $obj;
2761                         last;
2762                     }
2763                 }
2764             }
2765         } elsif ($command) {
2766             die "equal sign in command disabled (immature interface), ".
2767                 "you can set
2768  ! \$CPAN::Shell::ADVANCED_QUERY=1
2769 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2770 that may go away anytime.\n"
2771                     unless $ADVANCED_QUERY;
2772             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2773             my($matchcrit) = $criterion =~ m/^~(.+)/;
2774             for my $self (
2775                           sort
2776                           {$a->id cmp $b->id}
2777                           $CPAN::META->all_objects($class)
2778                          ) {
2779                 my $lhs = $self->$method() or next; # () for 5.00503
2780                 if ($matchcrit) {
2781                     push @m, $self if $lhs =~ m/$matchcrit/;
2782                 } else {
2783                     push @m, $self if $lhs eq $criterion;
2784                 }
2785             }
2786         } else {
2787             my($xarg) = $arg;
2788             if ( $class eq 'CPAN::Bundle' ) {
2789                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2790             } elsif ($class eq "CPAN::Distribution") {
2791                 $xarg = CPAN::Distribution->normalize($arg);
2792             } else {
2793                 $xarg =~ s/:+/::/g;
2794             }
2795             if ($CPAN::META->exists($class,$xarg)) {
2796                 $obj = $CPAN::META->instance($class,$xarg);
2797             } elsif ($CPAN::META->exists($class,$arg)) {
2798                 $obj = $CPAN::META->instance($class,$arg);
2799             } else {
2800                 next;
2801             }
2802             push @m, $obj;
2803         }
2804     }
2805     @m = sort {$a->id cmp $b->id} @m;
2806     if ( $CPAN::DEBUG ) {
2807         my $wantarray = wantarray;
2808         my $join_m = join ",", map {$_->id} @m;
2809         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2810     }
2811     return wantarray ? @m : $m[0];
2812 }
2813
2814 #-> sub CPAN::Shell::format_result ;
2815 sub format_result {
2816     my($self) = shift;
2817     my($type,@args) = @_;
2818     @args = '/./' unless @args;
2819     my(@result) = $self->expand($type,@args);
2820     my $result = @result == 1 ?
2821         $result[0]->as_string :
2822             @result == 0 ?
2823                 "No objects of type $type found for argument @args\n" :
2824                     join("",
2825                          (map {$_->as_glimpse} @result),
2826                          scalar @result, " items found\n",
2827                         );
2828     $result;
2829 }
2830
2831 #-> sub CPAN::Shell::report_fh ;
2832 {
2833     my $installation_report_fh;
2834     my $previously_noticed = 0;
2835
2836     sub report_fh {
2837         return $installation_report_fh if $installation_report_fh;
2838         if ($CPAN::META->has_inst("File::Temp")) {
2839             $installation_report_fh
2840                 = File::Temp->new(
2841                                   template => 'cpan_install_XXXX',
2842                                   suffix   => '.txt',
2843                                   unlink   => 0,
2844                                  );
2845         }
2846         unless ( $installation_report_fh ) {
2847             warn("Couldn't open installation report file; " .
2848                  "no report file will be generated."
2849                 ) unless $previously_noticed++;
2850         }
2851     }
2852 }
2853
2854
2855 # The only reason for this method is currently to have a reliable
2856 # debugging utility that reveals which output is going through which
2857 # channel. No, I don't like the colors ;-)
2858
2859 # to turn colordebugging on, write
2860 # cpan> o conf colorize_output 1
2861
2862 #-> sub CPAN::Shell::print_ornamented ;
2863 {
2864     my $print_ornamented_have_warned = 0;
2865     sub colorize_output {
2866         my $colorize_output = $CPAN::Config->{colorize_output};
2867         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2868             unless ($print_ornamented_have_warned++) {
2869                 # no myprint/mywarn within myprint/mywarn!
2870                 warn "Colorize_output is set to true but Term::ANSIColor is not
2871 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2872             }
2873             $colorize_output = 0;
2874         }
2875         return $colorize_output;
2876     }
2877 }
2878
2879
2880 #-> sub CPAN::Shell::print_ornamented ;
2881 sub print_ornamented {
2882     my($self,$what,$ornament) = @_;
2883     return unless defined $what;
2884
2885     local $| = 1; # Flush immediately
2886     if ( $CPAN::Be_Silent ) {
2887         print {report_fh()} $what;
2888         return;
2889     }
2890     my $swhat = "$what"; # stringify if it is an object
2891     if ($CPAN::Config->{term_is_latin}){
2892         # courtesy jhi:
2893         $swhat
2894             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2895     }
2896     if ($self->colorize_output) {
2897         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2898             # if you want to have this configurable, please file a bugreport
2899             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2900         }
2901         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2902         if ($@) {
2903             print "Term::ANSIColor rejects color[$ornament]: $@\n
2904 Please choose a different color (Hint: try 'o conf init /color/')\n";
2905         }
2906         print $color_on,
2907             $swhat,
2908                 Term::ANSIColor::color("reset");
2909     } else {
2910         print $swhat;
2911     }
2912 }
2913
2914 #-> sub CPAN::Shell::myprint ;
2915
2916 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2917 # where to use what! I think, we send everything to STDOUT and use
2918 # print for normal/good news and warn for news that need more
2919 # attention. Yes, this is our working contract for now.
2920 sub myprint {
2921     my($self,$what) = @_;
2922
2923     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2924 }
2925
2926 #-> sub CPAN::Shell::myexit ;
2927 sub myexit {
2928     my($self,$what) = @_;
2929     $self->myprint($what);
2930     exit;
2931 }
2932
2933 #-> sub CPAN::Shell::mywarn ;
2934 sub mywarn {
2935     my($self,$what) = @_;
2936     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2937 }
2938
2939 # only to be used for shell commands
2940 #-> sub CPAN::Shell::mydie ;
2941 sub mydie {
2942     my($self,$what) = @_;
2943     $self->mywarn($what);
2944
2945     # If it is the shell, we want the following die to be silent,
2946     # but if it is not the shell, we would need a 'die $what'. We need
2947     # to take care that only shell commands use mydie. Is this
2948     # possible?
2949
2950     die "\n";
2951 }
2952
2953 # sub CPAN::Shell::colorable_makemaker_prompt ;
2954 sub colorable_makemaker_prompt {
2955     my($foo,$bar) = @_;
2956     if (CPAN::Shell->colorize_output) {
2957         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2958         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2959         print $color_on;
2960     }
2961     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2962     if (CPAN::Shell->colorize_output) {
2963         print Term::ANSIColor::color('reset');
2964     }
2965     return $ans;
2966 }
2967
2968 # use this only for unrecoverable errors!
2969 #-> sub CPAN::Shell::unrecoverable_error ;
2970 sub unrecoverable_error {
2971     my($self,$what) = @_;
2972     my @lines = split /\n/, $what;
2973     my $longest = 0;
2974     for my $l (@lines) {
2975         $longest = length $l if length $l > $longest;
2976     }
2977     $longest = 62 if $longest > 62;
2978     for my $l (@lines) {
2979         if ($l =~ /^\s*$/){
2980             $l = "\n";
2981             next;
2982         }
2983         $l = "==> $l";
2984         if (length $l < 66) {
2985             $l = pack "A66 A*", $l, "<==";
2986         }
2987         $l .= "\n";
2988     }
2989     unshift @lines, "\n";
2990     $self->mydie(join "", @lines);
2991 }
2992
2993 #-> sub CPAN::Shell::mysleep ;
2994 sub mysleep {
2995     my($self, $sleep) = @_;
2996     if (CPAN->has_inst("Time::HiRes")) {
2997         Time::HiRes::sleep($sleep);
2998     } else {
2999         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3000     }
3001 }
3002
3003 #-> sub CPAN::Shell::setup_output ;
3004 sub setup_output {
3005     return if -t STDOUT;
3006     my $odef = select STDERR;
3007     $| = 1;
3008     select STDOUT;
3009     $| = 1;
3010     select $odef;
3011 }
3012
3013 #-> sub CPAN::Shell::rematein ;
3014 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3015 sub rematein {
3016     my $self = shift;
3017     my($meth,@some) = @_;
3018     my @pragma;
3019     while($meth =~ /^(ff?orce|notest)$/) {
3020         push @pragma, $meth;
3021         $meth = shift @some or
3022             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3023                                    "cannot continue");
3024     }
3025     setup_output();
3026     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3027
3028     # Here is the place to set "test_count" on all involved parties to
3029     # 0. We then can pass this counter on to the involved
3030     # distributions and those can refuse to test if test_count > X. In
3031     # the first stab at it we could use a 1 for "X".
3032
3033     # But when do I reset the distributions to start with 0 again?
3034     # Jost suggested to have a random or cycling interaction ID that
3035     # we pass through. But the ID is something that is just left lying
3036     # around in addition to the counter, so I'd prefer to set the
3037     # counter to 0 now, and repeat at the end of the loop. But what
3038     # about dependencies? They appear later and are not reset, they
3039     # enter the queue but not its copy. How do they get a sensible
3040     # test_count?
3041
3042     my $needs_recursion_protection = "make|test|install";
3043
3044     # construct the queue
3045     my($s,@s,@qcopy);
3046   STHING: foreach $s (@some) {
3047         my $obj;
3048         if (ref $s) {
3049             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3050             $obj = $s;
3051         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3052         } elsif ($s =~ m|^/|) { # looks like a regexp
3053             if (substr($s,-1,1) eq ".") {
3054                 $obj = CPAN::Shell->expandany($s);
3055             } else {
3056                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3057                                         "not supported.\nRejecting argument '$s'\n");
3058                 $CPAN::Frontend->mysleep(2);
3059                 next;
3060             }
3061         } elsif ($meth eq "ls") {
3062             $self->globls($s,\@pragma);
3063             next STHING;
3064         } else {
3065             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3066             $obj = CPAN::Shell->expandany($s);
3067         }
3068         if (0) {
3069         } elsif (ref $obj) {
3070             if ($meth =~ /^($needs_recursion_protection)$/) {
3071                 # it would be silly to check for recursion for look or dump
3072                 # (we are in CPAN::Shell::rematein)
3073                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3074                 eval {  $obj->color_cmd_tmps(0,1); };
3075                 if ($@){
3076                     if (ref $@
3077                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3078                         $CPAN::Frontend->mywarn($@);
3079                     } else {
3080                         if (0) {
3081                             require Carp;
3082                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3083                         }
3084                         die;
3085                     }
3086                 }
3087             }
3088             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
3089             push @qcopy, $obj;
3090         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3091             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3092             if ($meth =~ /^(dump|ls|reports)$/) {
3093                 $obj->$meth();
3094             } else {
3095                 $CPAN::Frontend->mywarn(
3096                                         join "",
3097                                         "Don't be silly, you can't $meth ",
3098                                         $obj->fullname,
3099                                         " ;-)\n"
3100                                        );
3101                 $CPAN::Frontend->mysleep(2);
3102             }
3103         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3104             CPAN::InfoObj->dump($s);
3105         } else {
3106             $CPAN::Frontend
3107                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3108                           qq{don't know what it is.
3109 Try the command
3110
3111     i /$s/
3112
3113 to find objects with matching identifiers.
3114 });
3115             $CPAN::Frontend->mysleep(2);
3116         }
3117     }
3118
3119     # queuerunner (please be warned: when I started to change the
3120     # queue to hold objects instead of names, I made one or two
3121     # mistakes and never found which. I reverted back instead)
3122     while (my $q = CPAN::Queue->first) {
3123         my $obj;
3124         my $s = $q->as_string;
3125         my $reqtype = $q->reqtype || "";
3126         $obj = CPAN::Shell->expandany($s);
3127         unless ($obj) {
3128             # don't know how this can happen, maybe we should panic,
3129             # but maybe we get a solution from the first user who hits
3130             # this unfortunate exception?
3131             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3132                                     "to an object. Skipping.\n");
3133             $CPAN::Frontend->mysleep(5);
3134             CPAN::Queue->delete_first($s);
3135             next;
3136         }
3137         $obj->{reqtype} ||= "";
3138         {
3139             # force debugging because CPAN::SQLite somehow delivers us
3140             # an empty object;
3141
3142             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3143
3144             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3145                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3146         }
3147         if ($obj->{reqtype}) {
3148             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3149                 $obj->{reqtype} = $reqtype;
3150                 if (
3151                     exists $obj->{install}
3152                     &&
3153                     (
3154                      UNIVERSAL::can($obj->{install},"failed") ?
3155                      $obj->{install}->failed :
3156                      $obj->{install} =~ /^NO/
3157                     )
3158                    ) {
3159                     delete $obj->{install};
3160                     $CPAN::Frontend->mywarn
3161                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3162                 }
3163             }
3164         } else {
3165             $obj->{reqtype} = $reqtype;
3166         }
3167
3168         for my $pragma (@pragma) {
3169             if ($pragma
3170                 &&
3171                 $obj->can($pragma)){
3172                 $obj->$pragma($meth);
3173             }
3174         }
3175         if (UNIVERSAL::can($obj, 'called_for')) {
3176             $obj->called_for($s);
3177         }
3178         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3179                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3180
3181         push @qcopy, $obj;
3182         if (! UNIVERSAL::can($obj,$meth)) {
3183             # Must never happen
3184             my $serialized = "";
3185             if (0) {
3186             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3187                 $serialized = YAML::Syck::Dump($obj);
3188             } elsif ($CPAN::META->has_inst("YAML")) {
3189                 $serialized = YAML::Dump($obj);
3190             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3191                 $serialized = Data::Dumper::Dumper($obj);
3192             } else {
3193                 require overload;
3194                 $serialized = overload::StrVal($obj);
3195             }
3196             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3197             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3198         } elsif ($obj->$meth()){
3199             CPAN::Queue->delete($s);
3200             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3201         } else {
3202             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3203         }
3204
3205         $obj->undelay;
3206         for my $pragma (@pragma) {
3207             my $unpragma = "un$pragma";
3208             if ($obj->can($unpragma)) {
3209                 $obj->$unpragma();
3210             }
3211         }
3212         CPAN::Queue->delete_first($s);
3213     }
3214     if ($meth =~ /^($needs_recursion_protection)$/) {
3215         for my $obj (@qcopy) {
3216             $obj->color_cmd_tmps(0,0);
3217         }
3218     }
3219 }
3220
3221 #-> sub CPAN::Shell::recent ;
3222 sub recent {
3223   my($self) = @_;
3224
3225   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3226   return;
3227 }
3228
3229 {
3230     # set up the dispatching methods
3231     no strict "refs";
3232     for my $command (qw(
3233                         clean
3234                         cvs_import
3235                         dump
3236                         force
3237                         fforce
3238                         get
3239                         install
3240                         look
3241                         ls
3242                         make
3243                         notest
3244                         perldoc
3245                         readme
3246                         reports
3247                         test
3248                        )) {
3249         *$command = sub { shift->rematein($command, @_); };
3250     }
3251 }
3252
3253 package CPAN::LWP::UserAgent;
3254 use strict;
3255
3256 sub config {
3257     return if $SETUPDONE;
3258     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3259         require LWP::UserAgent;
3260         @ISA = qw(Exporter LWP::UserAgent);
3261         $SETUPDONE++;
3262     } else {
3263         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3264     }
3265 }
3266
3267 sub get_basic_credentials {
3268     my($self, $realm, $uri, $proxy) = @_;
3269     if ($USER && $PASSWD) {
3270         return ($USER, $PASSWD);
3271     }
3272     if ( $proxy ) {
3273         ($USER,$PASSWD) = $self->get_proxy_credentials();
3274     } else {
3275         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3276     }
3277     return($USER,$PASSWD);
3278 }
3279
3280 sub get_proxy_credentials {
3281     my $self = shift;
3282     my ($user, $password);
3283     if ( defined $CPAN::Config->{proxy_user} &&
3284          defined $CPAN::Config->{proxy_pass}) {
3285         $user = $CPAN::Config->{proxy_user};
3286         $password = $CPAN::Config->{proxy_pass};
3287         return ($user, $password);
3288     }
3289     my $username_prompt = "\nProxy authentication needed!
3290  (Note: to permanently configure username and password run
3291    o conf proxy_user your_username
3292    o conf proxy_pass your_password
3293      )\nUsername:";
3294     ($user, $password) =
3295         _get_username_and_password_from_user($username_prompt);
3296     return ($user,$password);
3297 }
3298
3299 sub get_non_proxy_credentials {
3300     my $self = shift;
3301     my ($user,$password);
3302     if ( defined $CPAN::Config->{username} &&
3303          defined $CPAN::Config->{password}) {
3304         $user = $CPAN::Config->{username};
3305         $password = $CPAN::Config->{password};
3306         return ($user, $password);
3307     }
3308     my $username_prompt = "\nAuthentication needed!
3309      (Note: to permanently configure username and password run
3310        o conf username your_username
3311        o conf password your_password
3312      )\nUsername:";
3313
3314     ($user, $password) =
3315         _get_username_and_password_from_user($username_prompt);
3316     return ($user,$password);
3317 }
3318
3319 sub _get_username_and_password_from_user {
3320     my $username_message = shift;
3321     my ($username,$password);
3322
3323     ExtUtils::MakeMaker->import(qw(prompt));
3324     $username = prompt($username_message);
3325         if ($CPAN::META->has_inst("Term::ReadKey")) {
3326             Term::ReadKey::ReadMode("noecho");
3327         }
3328     else {
3329         $CPAN::Frontend->mywarn(
3330             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3331         );
3332     }
3333     $password = prompt("Password:");
3334
3335         if ($CPAN::META->has_inst("Term::ReadKey")) {
3336             Term::ReadKey::ReadMode("restore");
3337         }
3338         $CPAN::Frontend->myprint("\n\n");
3339     return ($username,$password);
3340 }
3341
3342 # mirror(): Its purpose is to deal with proxy authentication. When we
3343 # call SUPER::mirror, we relly call the mirror method in
3344 # LWP::UserAgent. LWP::UserAgent will then call
3345 # $self->get_basic_credentials or some equivalent and this will be
3346 # $self->dispatched to our own get_basic_credentials method.
3347
3348 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3349
3350 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3351 # although we have gone through our get_basic_credentials, the proxy
3352 # server refuses to connect. This could be a case where the username or
3353 # password has changed in the meantime, so I'm trying once again without
3354 # $USER and $PASSWD to give the get_basic_credentials routine another
3355 # chance to set $USER and $PASSWD.
3356
3357 # mirror(): Its purpose is to deal with proxy authentication. When we
3358 # call SUPER::mirror, we relly call the mirror method in
3359 # LWP::UserAgent. LWP::UserAgent will then call
3360 # $self->get_basic_credentials or some equivalent and this will be
3361 # $self->dispatched to our own get_basic_credentials method.
3362
3363 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3364
3365 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3366 # although we have gone through our get_basic_credentials, the proxy
3367 # server refuses to connect. This could be a case where the username or
3368 # password has changed in the meantime, so I'm trying once again without
3369 # $USER and $PASSWD to give the get_basic_credentials routine another
3370 # chance to set $USER and $PASSWD.
3371
3372 sub mirror {
3373     my($self,$url,$aslocal) = @_;
3374     my $result = $self->SUPER::mirror($url,$aslocal);
3375     if ($result->code == 407) {
3376         undef $USER;
3377         undef $PASSWD;
3378         $result = $self->SUPER::mirror($url,$aslocal);
3379     }
3380     $result;
3381 }
3382
3383 package CPAN::FTP;
3384 use strict;
3385
3386 #-> sub CPAN::FTP::ftp_statistics
3387 # if they want to rewrite, they need to pass in a filehandle
3388 sub _ftp_statistics {
3389     my($self,$fh) = @_;
3390     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3391     $fh ||= FileHandle->new;
3392     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3393     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3394     my $sleep = 1;
3395     my $waitstart;
3396     while (!flock $fh, $locktype|LOCK_NB) {
3397         $waitstart ||= localtime();
3398         if ($sleep>3) {
3399             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3400         }
3401         $CPAN::Frontend->mysleep($sleep);
3402         if ($sleep <= 3) {
3403             $sleep+=0.33;
3404         } elsif ($sleep <=6) {
3405             $sleep+=0.11;
3406         }
3407     }
3408     my $stats = eval { CPAN->_yaml_loadfile($file); };
3409     if ($@) {
3410         if (ref $@) {
3411             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3412                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3413                 return;
3414             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3415                 $CPAN::Frontend->mydie($@);
3416             }
3417         } else {
3418             $CPAN::Frontend->mydie($@);
3419         }
3420     }
3421     return $stats->[0];
3422 }
3423
3424 #-> sub CPAN::FTP::_mytime
3425 sub _mytime () {
3426     if (CPAN->has_inst("Time::HiRes")) {
3427         return Time::HiRes::time();
3428     } else {
3429         return time;
3430     }
3431 }
3432
3433 #-> sub CPAN::FTP::_new_stats
3434 sub _new_stats {
3435     my($self,$file) = @_;
3436     my $ret = {
3437                file => $file,
3438                attempts => [],
3439                start => _mytime,
3440               };
3441     $ret;
3442 }
3443
3444 #-> sub CPAN::FTP::_add_to_statistics
3445 sub _add_to_statistics {
3446     my($self,$stats) = @_;
3447     my $yaml_module = CPAN::_yaml_module;
3448     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3449     if ($CPAN::META->has_inst($yaml_module)) {
3450         $stats->{thesiteurl} = $ThesiteURL;
3451         if (CPAN->has_inst("Time::HiRes")) {
3452             $stats->{end} = Time::HiRes::time();
3453         } else {
3454             $stats->{end} = time;
3455         }
3456         my $fh = FileHandle->new;
3457         my $time = time;
3458         my $sdebug = 0;
3459         my @debug;
3460         @debug = $time if $sdebug;
3461         my $fullstats = $self->_ftp_statistics($fh);
3462         close $fh;
3463         $fullstats->{history} ||= [];
3464         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3465         push @debug, time if $sdebug;
3466         push @{$fullstats->{history}}, $stats;
3467         # arbitrary hardcoded constants until somebody demands to have
3468         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3469         # YAML::Syck 0.82 has no noticable performance problem with 999;
3470         while (
3471                @{$fullstats->{history}} > 99
3472                || $time - $fullstats->{history}[0]{start} > 14*86400
3473               ) {
3474             shift @{$fullstats->{history}}
3475         }
3476         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3477         push @debug, time if $sdebug;
3478         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3479         # need no eval because if this fails, it is serious
3480         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3481         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3482         if ( $sdebug ) {
3483             local $CPAN::DEBUG = 512; # FTP
3484             push @debug, time;
3485             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3486                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3487                                 @debug,
3488                                ));
3489         }
3490         # Win32 cannot rename a file to an existing filename
3491         unlink($sfile) if ($^O eq 'MSWin32');
3492         rename "$sfile.$$", $sfile
3493             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3494     }
3495 }
3496
3497 # if file is CHECKSUMS, suggest the place where we got the file to be
3498 # checked from, maybe only for young files?
3499 #-> sub CPAN::FTP::_recommend_url_for
3500 sub _recommend_url_for {
3501     my($self, $file) = @_;
3502     my $urllist = $self->_get_urllist;
3503     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3504         my $fullstats = $self->_ftp_statistics();
3505         my $history = $fullstats->{history} || [];
3506         while (my $last = pop @$history) {
3507             last if $last->{end} - time > 3600; # only young results are interesting
3508             next unless $last->{file}; # dirname of nothing dies!
3509             next unless $file eq File::Basename::dirname($last->{file});
3510             return $last->{thesiteurl};
3511         }
3512     }
3513     if ($CPAN::Config->{randomize_urllist}
3514         &&
3515         rand(1) < $CPAN::Config->{randomize_urllist}
3516        ) {
3517         $urllist->[int rand scalar @$urllist];
3518     } else {
3519         return ();
3520     }
3521 }
3522
3523 #-> sub CPAN::FTP::_get_urllist
3524 sub _get_urllist {
3525     my($self) = @_;
3526     $CPAN::Config->{urllist} ||= [];
3527     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3528         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3529         $CPAN::Config->{urllist} = [];
3530     }
3531     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3532     for my $u (@urllist) {
3533         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3534         if (UNIVERSAL::can($u,"text")) {
3535             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3536         } else {
3537             $u .= "/" unless substr($u,-1) eq "/";
3538             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3539         }
3540     }
3541     \@urllist;
3542 }
3543
3544 #-> sub CPAN::FTP::ftp_get ;
3545 sub ftp_get {
3546     my($class,$host,$dir,$file,$target) = @_;
3547     $class->debug(
3548                   qq[Going to fetch file [$file] from dir [$dir]
3549         on host [$host] as local [$target]\n]
3550                  ) if $CPAN::DEBUG;
3551     my $ftp = Net::FTP->new($host);
3552     unless ($ftp) {
3553         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3554         return;
3555     }
3556     return 0 unless defined $ftp;
3557     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3558     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3559     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3560         my $msg = $ftp->message;
3561         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3562         return;
3563     }
3564     unless ( $ftp->cwd($dir) ){
3565         my $msg = $ftp->message;
3566         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3567         return;
3568     }
3569     $ftp->binary;
3570     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3571     unless ( $ftp->get($file,$target) ){
3572         my $msg = $ftp->message;
3573         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3574         return;
3575     }
3576     $ftp->quit; # it's ok if this fails
3577     return 1;
3578 }
3579
3580 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3581
3582  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3583  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3584  # > ***************
3585  # > *** 1562,1567 ****
3586  # > --- 1562,1580 ----
3587  # >       return 1 if substr($url,0,4) eq "file";
3588  # >       return 1 unless $url =~ m|://([^/]+)|;
3589  # >       my $host = $1;
3590  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3591  # > +     if ($proxy) {
3592  # > +         $proxy =~ m|://([^/:]+)|;
3593  # > +         $proxy = $1;
3594  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3595  # > +         if ($noproxy) {
3596  # > +             if ($host !~ /$noproxy$/) {
3597  # > +                 $host = $proxy;
3598  # > +             }
3599  # > +         } else {
3600  # > +             $host = $proxy;
3601  # > +         }
3602  # > +     }
3603  # >       require Net::Ping;
3604  # >       return 1 unless $Net::Ping::VERSION >= 2;
3605  # >       my $p;
3606
3607
3608 #-> sub CPAN::FTP::localize ;
3609 sub localize {
3610     my($self,$file,$aslocal,$force) = @_;
3611     $force ||= 0;
3612     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3613         unless defined $aslocal;
3614     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3615         if $CPAN::DEBUG;
3616
3617     if ($^O eq 'MacOS') {
3618         # Comment by AK on 2000-09-03: Uniq short filenames would be
3619         # available in CHECKSUMS file
3620         my($name, $path) = File::Basename::fileparse($aslocal, '');
3621         if (length($name) > 31) {
3622             $name =~ s/(
3623                         \.(
3624                            readme(\.(gz|Z))? |
3625                            (tar\.)?(gz|Z) |
3626                            tgz |
3627                            zip |
3628                            pm\.(gz|Z)
3629                           )
3630                        )$//x;
3631             my $suf = $1;
3632             my $size = 31 - length($suf);
3633             while (length($name) > $size) {
3634                 chop $name;
3635             }
3636             $name .= $suf;
3637             $aslocal = File::Spec->catfile($path, $name);
3638         }
3639     }
3640
3641     if (-f $aslocal && -r _ && !($force & 1)){
3642         my $size;
3643         if ($size = -s $aslocal) {
3644             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3645             return $aslocal;
3646         } else {
3647             # empty file from a previous unsuccessful attempt to download it
3648             unlink $aslocal or
3649                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3650                                        "could not remove.");
3651         }
3652     }
3653     my($maybe_restore) = 0;
3654     if (-f $aslocal){
3655         rename $aslocal, "$aslocal.bak$$";
3656         $maybe_restore++;
3657     }
3658
3659     my($aslocal_dir) = File::Basename::dirname($aslocal);
3660     File::Path::mkpath($aslocal_dir);
3661     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3662         qq{directory "$aslocal_dir".
3663     I\'ll continue, but if you encounter problems, they may be due
3664     to insufficient permissions.\n}) unless -w $aslocal_dir;
3665
3666     # Inheritance is not easier to manage than a few if/else branches
3667     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3668         unless ($Ua) {
3669             CPAN::LWP::UserAgent->config;
3670             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3671             if ($@) {
3672                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3673                     if $CPAN::DEBUG;
3674             } else {
3675                 my($var);
3676                 $Ua->proxy('ftp',  $var)
3677                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3678                 $Ua->proxy('http', $var)
3679                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3680                 $Ua->no_proxy($var)
3681                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3682             }
3683         }
3684     }
3685     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3686         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3687     }
3688
3689     # Try the list of urls for each single object. We keep a record
3690     # where we did get a file from
3691     my(@reordered,$last);
3692     my $ccurllist = $self->_get_urllist;
3693     $last = $#$ccurllist;
3694     if ($force & 2) { # local cpans probably out of date, don't reorder
3695         @reordered = (0..$last);
3696     } else {
3697         @reordered =
3698             sort {
3699                 (substr($ccurllist->[$b],0,4) eq "file")
3700                     <=>
3701                 (substr($ccurllist->[$a],0,4) eq "file")
3702                     or
3703                 defined($ThesiteURL)
3704                     and
3705                 ($ccurllist->[$b] eq $ThesiteURL)
3706                     <=>
3707                 ($ccurllist->[$a] eq $ThesiteURL)
3708             } 0..$last;
3709     }
3710     my(@levels);
3711     $Themethod ||= "";
3712     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3713     if ($Themethod) {
3714         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3715     } else {
3716         @levels = qw/easy hard hardest/;
3717     }
3718     @levels = qw/easy/ if $^O eq 'MacOS';
3719     my($levelno);
3720     local $ENV{FTP_PASSIVE} =
3721         exists $CPAN::Config->{ftp_passive} ?
3722         $CPAN::Config->{ftp_passive} : 1;
3723     my $ret;
3724     my $stats = $self->_new_stats($file);
3725   LEVEL: for $levelno (0..$#levels) {
3726         my $level = $levels[$levelno];
3727         my $method = "host$level";
3728         my @host_seq = $level eq "easy" ?
3729             @reordered : 0..$last;  # reordered has CDROM up front
3730         my @urllist = map { $ccurllist->[$_] } @host_seq;
3731         for my $u (@CPAN::Defaultsites) {
3732             push @urllist, $u unless grep { $_ eq $u } @urllist;
3733         }
3734         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3735         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3736         if (my $recommend = $self->_recommend_url_for($file)) {
3737             @urllist = grep { $_ ne $recommend } @urllist;
3738             unshift @urllist, $recommend;
3739         }
3740         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3741         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3742         if ($ret) {
3743             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3744             if ($ret eq $aslocal_tempfile) {
3745                 # if we got it exactly as we asked for, only then we
3746                 # want to rename
3747                 rename $aslocal_tempfile, $aslocal
3748                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3749                                               "'$ret' to '$aslocal': $!");
3750                 $ret = $aslocal;
3751             }
3752             $Themethod = $level;
3753             my $now = time;
3754             # utime $now, $now, $aslocal; # too bad, if we do that, we
3755                                           # might alter a local mirror
3756             $self->debug("level[$level]") if $CPAN::DEBUG;
3757             last LEVEL;
3758         } else {
3759             unlink $aslocal_tempfile;
3760             last if $CPAN::Signal; # need to cleanup
3761         }
3762     }
3763     if ($ret) {
3764         $stats->{filesize} = -s $ret;
3765     }
3766     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3767     $self->_add_to_statistics($stats);
3768     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3769     if ($ret) {
3770         unlink "$aslocal.bak$$";
3771         return $ret;
3772     }
3773     unless ($CPAN::Signal) {
3774         my(@mess);
3775         local $" = " ";
3776         if (@{$CPAN::Config->{urllist}}) {
3777             push @mess,
3778                 qq{Please check, if the URLs I found in your configuration file \(}.
3779                     join(", ", @{$CPAN::Config->{urllist}}).
3780                         qq{\) are valid.};
3781         } else {
3782             push @mess, qq{Your urllist is empty!};
3783         }
3784         push @mess, qq{The urllist can be edited.},
3785             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3786         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3787         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3788         $CPAN::Frontend->mysleep(2);
3789     }
3790     if ($maybe_restore) {
3791         rename "$aslocal.bak$$", $aslocal;
3792         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3793                                  $self->ls($aslocal));
3794         return $aslocal;
3795     }
3796     return;
3797 }
3798
3799 sub _set_attempt {
3800     my($self,$stats,$method,$url) = @_;
3801     push @{$stats->{attempts}}, {
3802                                  method => $method,
3803                                  start => _mytime,
3804                                  url => $url,
3805                                 };
3806 }
3807
3808 # package CPAN::FTP;
3809 sub hosteasy {
3810     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3811     my($ro_url);
3812   HOSTEASY: for $ro_url (@$host_seq) {
3813         $self->_set_attempt($stats,"easy",$ro_url);
3814         my $url .= "$ro_url$file";
3815         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3816         if ($url =~ /^file:/) {
3817             my $l;
3818             if ($CPAN::META->has_inst('URI::URL')) {
3819                 my $u =  URI::URL->new($url);
3820                 $l = $u->path;
3821             } else { # works only on Unix, is poorly constructed, but
3822                 # hopefully better than nothing.
3823                 # RFC 1738 says fileurl BNF is
3824                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3825                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3826                 # the code
3827                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3828                 $l =~ s|^file:||;                   # assume they
3829                                                     # meant
3830                                                     # file://localhost
3831                 $l =~ s|^/||s
3832                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3833             }
3834             $self->debug("local file[$l]") if $CPAN::DEBUG;
3835             if ( -f $l && -r _) {
3836                 $ThesiteURL = $ro_url;
3837                 return $l;
3838             }
3839             if ($l =~ /(.+)\.gz$/) {
3840                 my $ungz = $1;
3841                 if ( -f $ungz && -r _) {
3842                     $ThesiteURL = $ro_url;
3843                     return $ungz;
3844                 }
3845             }
3846             # Maybe mirror has compressed it?
3847             if (-f "$l.gz") {
3848                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3849                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3850                 if ( -f $aslocal) {
3851                     $ThesiteURL = $ro_url;
3852                     return $aslocal;
3853                 }
3854             }
3855         }
3856         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3857         if ($CPAN::META->has_usable('LWP')) {
3858             $CPAN::Frontend->myprint("Fetching with LWP:
3859   $url
3860 ");
3861             unless ($Ua) {
3862                 CPAN::LWP::UserAgent->config;
3863                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3864                 if ($@) {
3865                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3866                 }
3867             }
3868             my $res = $Ua->mirror($url, $aslocal);
3869             if ($res->is_success) {
3870                 $ThesiteURL = $ro_url;
3871                 my $now = time;
3872                 utime $now, $now, $aslocal; # download time is more
3873                                             # important than upload
3874                                             # time
3875                 return $aslocal;
3876             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3877                 my $gzurl = "$url.gz";
3878                 $CPAN::Frontend->myprint("Fetching with LWP:
3879   $gzurl
3880 ");
3881                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3882                 if ($res->is_success) {
3883                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3884                         $ThesiteURL = $ro_url;
3885                         return $aslocal;
3886                     }
3887                 }
3888             } else {
3889                 $CPAN::Frontend->myprint(sprintf(
3890                                                  "LWP failed with code[%s] message[%s]\n",
3891                                                  $res->code,
3892                                                  $res->message,
3893                                                 ));
3894                 # Alan Burlison informed me that in firewall environments
3895                 # Net::FTP can still succeed where LWP fails. So we do not
3896                 # skip Net::FTP anymore when LWP is available.
3897             }
3898         } else {
3899             $CPAN::Frontend->mywarn("  LWP not available\n");
3900         }
3901         return if $CPAN::Signal;
3902         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3903             # that's the nice and easy way thanks to Graham
3904             $self->debug("recognized ftp") if $CPAN::DEBUG;
3905             my($host,$dir,$getfile) = ($1,$2,$3);
3906             if ($CPAN::META->has_usable('Net::FTP')) {
3907                 $dir =~ s|/+|/|g;
3908                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3909   $url
3910 ");
3911                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3912                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3913                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3914                     $ThesiteURL = $ro_url;
3915                     return $aslocal;
3916                 }
3917                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3918                     my $gz = "$aslocal.gz";
3919                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3920   $url.gz
3921 ");
3922                     if (CPAN::FTP->ftp_get($host,
3923                                            $dir,
3924                                            "$getfile.gz",
3925                                            $gz) &&
3926                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3927                        ){
3928                         $ThesiteURL = $ro_url;
3929                         return $aslocal;
3930                     }
3931                 }
3932                 # next HOSTEASY;
3933             } else {
3934                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3935             }
3936         }
3937         if (
3938             UNIVERSAL::can($ro_url,"text")
3939             and
3940             $ro_url->{FROM} eq "USER"
3941            ){
3942             ##address #17973: default URLs should not try to override
3943             ##user-defined URLs just because LWP is not available
3944             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3945             return $ret if $ret;
3946         }
3947         return if $CPAN::Signal;
3948     }
3949 }
3950
3951 # package CPAN::FTP;
3952 sub hosthard {
3953   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3954
3955   # Came back if Net::FTP couldn't establish connection (or
3956   # failed otherwise) Maybe they are behind a firewall, but they
3957   # gave us a socksified (or other) ftp program...
3958
3959   my($ro_url);
3960   my($devnull) = $CPAN::Config->{devnull} || "";
3961   # < /dev/null ";
3962   my($aslocal_dir) = File::Basename::dirname($aslocal);
3963   File::Path::mkpath($aslocal_dir);
3964   HOSTHARD: for $ro_url (@$host_seq) {
3965         $self->_set_attempt($stats,"hard",$ro_url);
3966         my $url = "$ro_url$file";
3967         my($proto,$host,$dir,$getfile);
3968
3969         # Courtesy Mark Conty mark_conty@cargill.com change from
3970         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3971         # to
3972         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3973           # proto not yet used
3974           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3975         } else {
3976           next HOSTHARD; # who said, we could ftp anything except ftp?
3977         }
3978         next HOSTHARD if $proto eq "file"; # file URLs would have had
3979                                            # success above. Likely a bogus URL
3980
3981         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3982
3983         # Try the most capable first and leave ncftp* for last as it only
3984         # does FTP.
3985       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3986           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3987           next unless defined $funkyftp;
3988           next if $funkyftp =~ /^\s*$/;
3989
3990           my($asl_ungz, $asl_gz);
3991           ($asl_ungz = $aslocal) =~ s/\.gz//;
3992           $asl_gz = "$asl_ungz.gz";
3993
3994           my($src_switch) = "";
3995           my($chdir) = "";
3996           my($stdout_redir) = " > $asl_ungz";
3997           if ($f eq "lynx"){
3998             $src_switch = " -source";
3999           } elsif ($f eq "ncftp"){
4000             $src_switch = " -c";
4001           } elsif ($f eq "wget"){
4002             $src_switch = " -O $asl_ungz";
4003             $stdout_redir = "";
4004           } elsif ($f eq 'curl'){
4005             $src_switch = ' -L -f -s -S --netrc-optional';
4006           }
4007
4008           if ($f eq "ncftpget"){
4009             $chdir = "cd $aslocal_dir && ";
4010             $stdout_redir = "";
4011           }
4012           $CPAN::Frontend->myprint(
4013                                    qq[
4014 Trying with "$funkyftp$src_switch" to get
4015     $url
4016 ]);
4017           my($system) =
4018               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4019           $self->debug("system[$system]") if $CPAN::DEBUG;
4020           my($wstatus) = system($system);
4021           if ($f eq "lynx") {
4022               # lynx returns 0 when it fails somewhere
4023               if (-s $asl_ungz) {
4024                   my $content = do { local *FH;
4025                                      open FH, $asl_ungz or die;
4026                                      local $/;
4027                                      <FH> };
4028                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4029                       $CPAN::Frontend->mywarn(qq{
4030 No success, the file that lynx has has downloaded looks like an error message:
4031 $content
4032 });
4033                       $CPAN::Frontend->mysleep(1);
4034                       next DLPRG;
4035                   }
4036               } else {
4037                   $CPAN::Frontend->myprint(qq{
4038 No success, the file that lynx has has downloaded is an empty file.
4039 });
4040                   next DLPRG;
4041               }
4042           }
4043           if ($wstatus == 0) {
4044             if (-s $aslocal) {
4045               # Looks good
4046             } elsif ($asl_ungz ne $aslocal) {
4047               # test gzip integrity
4048               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4049                   # e.g. foo.tar is gzipped --> foo.tar.gz
4050                   rename $asl_ungz, $aslocal;
4051               } else {
4052                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4053               }
4054             }
4055             $ThesiteURL = $ro_url;
4056             return $aslocal;
4057           } elsif ($url !~ /\.gz(?!\n)\Z/) {
4058             unlink $asl_ungz if
4059                 -f $asl_ungz && -s _ == 0;
4060             my $gz = "$aslocal.gz";
4061             my $gzurl = "$url.gz";
4062             $CPAN::Frontend->myprint(
4063                                      qq[
4064 Trying with "$funkyftp$src_switch" to get
4065   $url.gz
4066 ]);
4067             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4068             $self->debug("system[$system]") if $CPAN::DEBUG;
4069             my($wstatus);
4070             if (($wstatus = system($system)) == 0
4071                 &&
4072                 -s $asl_gz
4073                ) {
4074               # test gzip integrity
4075                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4076                 if ($ct && $ct->gtest) {
4077                     $ct->gunzip($aslocal);
4078                 } else {
4079                     # somebody uncompressed file for us?
4080                     rename $asl_ungz, $aslocal;
4081                 }
4082                 $ThesiteURL = $ro_url;
4083                 return $aslocal;
4084             } else {
4085               unlink $asl_gz if -f $asl_gz;
4086             }
4087           } else {
4088             my $estatus = $wstatus >> 8;
4089             my $size = -f $aslocal ?
4090                 ", left\n$aslocal with size ".-s _ :
4091                     "\nWarning: expected file [$aslocal] doesn't exist";
4092             $CPAN::Frontend->myprint(qq{
4093 System call "$system"
4094 returned status $estatus (wstat $wstatus)$size
4095 });
4096           }
4097           return if $CPAN::Signal;
4098         } # transfer programs
4099     } # host
4100 }
4101
4102 # package CPAN::FTP;
4103 sub hosthardest {
4104     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4105
4106     my($ro_url);
4107     my($aslocal_dir) = File::Basename::dirname($aslocal);
4108     File::Path::mkpath($aslocal_dir);
4109     my $ftpbin = $CPAN::Config->{ftp};
4110     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4111         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4112         return;
4113     }
4114     $CPAN::Frontend->mywarn(qq{
4115 As a last ressort we now switch to the external ftp command '$ftpbin'
4116 to get '$aslocal'.
4117
4118 Doing so often leads to problems that are hard to diagnose.
4119
4120 If you're victim of such problems, please consider unsetting the ftp
4121 config variable with
4122
4123     o conf ftp ""
4124     o conf commit
4125
4126 });
4127     $CPAN::Frontend->mysleep(2);
4128   HOSTHARDEST: for $ro_url (@$host_seq) {
4129         $self->_set_attempt($stats,"hardest",$ro_url);
4130         my $url = "$ro_url$file";
4131         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4132         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4133             next;
4134         }
4135         my($host,$dir,$getfile) = ($1,$2,$3);
4136         my $timestamp = 0;
4137         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4138            $ctime,$blksize,$blocks) = stat($aslocal);
4139         $timestamp = $mtime ||= 0;
4140         my($netrc) = CPAN::FTP::netrc->new;
4141         my($netrcfile) = $netrc->netrc;
4142         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4143         my $targetfile = File::Basename::basename($aslocal);
4144         my(@dialog);
4145         push(
4146              @dialog,
4147              "lcd $aslocal_dir",
4148              "cd /",
4149              map("cd $_", split /\//, $dir), # RFC 1738
4150              "bin",
4151              "get $getfile $targetfile",
4152              "quit"
4153             );
4154         if (! $netrcfile) {
4155             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4156         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4157             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4158                                 $netrc->hasdefault,
4159                                 $netrc->contains($host))) if $CPAN::DEBUG;
4160             if ($netrc->protected) {
4161                 my $dialog = join "", map { "    $_\n" } @dialog;
4162                 my $netrc_explain;
4163                 if ($netrc->contains($host)) {
4164                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4165                         "manages the login";
4166                 } else {
4167                     $netrc_explain = "Relying that your default .netrc entry ".
4168                         "manages the login";
4169                 }
4170                 $CPAN::Frontend->myprint(qq{
4171   Trying with external ftp to get
4172     $url
4173   $netrc_explain
4174   Going to send the dialog
4175 $dialog
4176 }
4177                      );
4178                 $self->talk_ftp("$ftpbin$verbose $host",
4179                                 @dialog);
4180                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4181                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4182                 $mtime ||= 0;
4183                 if ($mtime > $timestamp) {
4184                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4185                     $ThesiteURL = $ro_url;
4186                     return $aslocal;
4187                 } else {
4188                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4189                 }
4190                 return if $CPAN::Signal;
4191             } else {
4192                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4193                                         qq{correctly protected.\n});
4194             }
4195         } else {
4196             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4197   nor does it have a default entry\n");
4198         }
4199
4200         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4201         # then and login manually to host, using e-mail as
4202         # password.
4203         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4204         unshift(
4205                 @dialog,
4206                 "open $host",
4207                 "user anonymous $Config::Config{'cf_email'}"
4208                );
4209         my $dialog = join "", map { "    $_\n" } @dialog;
4210         $CPAN::Frontend->myprint(qq{
4211   Trying with external ftp to get
4212     $url
4213   Going to send the dialog
4214 $dialog
4215 }
4216                      );
4217         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4218         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4219          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4220         $mtime ||= 0;
4221         if ($mtime > $timestamp) {
4222             $CPAN::Frontend->myprint("GOT $aslocal\n");
4223             $ThesiteURL = $ro_url;
4224             return $aslocal;
4225         } else {
4226             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4227         }
4228         return if $CPAN::Signal;
4229         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4230         $CPAN::Frontend->mysleep(2);
4231     } # host
4232 }
4233
4234 # package CPAN::FTP;
4235 sub talk_ftp {
4236     my($self,$command,@dialog) = @_;
4237     my $fh = FileHandle->new;
4238     $fh->open("|$command") or die "Couldn't open ftp: $!";
4239     foreach (@dialog) { $fh->print("$_\n") }
4240     $fh->close;         # Wait for process to complete
4241     my $wstatus = $?;
4242     my $estatus = $wstatus >> 8;
4243     $CPAN::Frontend->myprint(qq{
4244 Subprocess "|$command"
4245   returned status $estatus (wstat $wstatus)
4246 }) if $wstatus;
4247 }
4248
4249 # find2perl needs modularization, too, all the following is stolen
4250 # from there
4251 # CPAN::FTP::ls
4252 sub ls {
4253     my($self,$name) = @_;
4254     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4255      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4256
4257     my($perms,%user,%group);
4258     my $pname = $name;
4259
4260     if ($blocks) {
4261         $blocks = int(($blocks + 1) / 2);
4262     }
4263     else {
4264         $blocks = int(($sizemm + 1023) / 1024);
4265     }
4266
4267     if    (-f _) { $perms = '-'; }
4268     elsif (-d _) { $perms = 'd'; }
4269     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4270     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4271     elsif (-p _) { $perms = 'p'; }
4272     elsif (-S _) { $perms = 's'; }
4273     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4274
4275     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4276     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4277     my $tmpmode = $mode;
4278     my $tmp = $rwx[$tmpmode & 7];
4279     $tmpmode >>= 3;
4280     $tmp = $rwx[$tmpmode & 7] . $tmp;
4281     $tmpmode >>= 3;
4282     $tmp = $rwx[$tmpmode & 7] . $tmp;
4283     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4284     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4285     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4286     $perms .= $tmp;
4287
4288     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4289     my $group = $group{$gid} || $gid;
4290
4291     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4292     my($timeyear);
4293     my($moname) = $moname[$mon];
4294     if (-M _ > 365.25 / 2) {
4295         $timeyear = $year + 1900;
4296     }
4297     else {
4298         $timeyear = sprintf("%02d:%02d", $hour, $min);
4299     }
4300
4301     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4302             $ino,
4303                  $blocks,
4304                       $perms,
4305                             $nlink,
4306                                 $user,
4307                                      $group,
4308                                           $sizemm,
4309                                               $moname,
4310                                                  $mday,
4311                                                      $timeyear,
4312                                                          $pname;
4313 }
4314
4315 package CPAN::FTP::netrc;
4316 use strict;
4317
4318 # package CPAN::FTP::netrc;
4319 sub new {
4320     my($class) = @_;
4321     my $home = CPAN::HandleConfig::home;
4322     my $file = File::Spec->catfile($home,".netrc");
4323
4324     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4325        $atime,$mtime,$ctime,$blksize,$blocks)
4326         = stat($file);
4327     $mode ||= 0;
4328     my $protected = 0;
4329
4330     my($fh,@machines,$hasdefault);
4331     $hasdefault = 0;
4332     $fh = FileHandle->new or die "Could not create a filehandle";
4333
4334     if($fh->open($file)){
4335         $protected = ($mode & 077) == 0;
4336         local($/) = "";
4337       NETRC: while (<$fh>) {
4338             my(@tokens) = split " ", $_;
4339           TOKEN: while (@tokens) {
4340                 my($t) = shift @tokens;
4341                 if ($t eq "default"){
4342                     $hasdefault++;
4343                     last NETRC;
4344                 }
4345                 last TOKEN if $t eq "macdef";
4346                 if ($t eq "machine") {
4347                     push @machines, shift @tokens;
4348                 }
4349             }
4350         }
4351     } else {
4352         $file = $hasdefault = $protected = "";
4353     }
4354
4355     bless {
4356            'mach' => [@machines],
4357            'netrc' => $file,
4358            'hasdefault' => $hasdefault,
4359            'protected' => $protected,
4360           }, $class;
4361 }
4362
4363 # CPAN::FTP::netrc::hasdefault;
4364 sub hasdefault { shift->{'hasdefault'} }
4365 sub netrc      { shift->{'netrc'}      }
4366 sub protected  { shift->{'protected'}  }
4367 sub contains {
4368     my($self,$mach) = @_;
4369     for ( @{$self->{'mach'}} ) {
4370         return 1 if $_ eq $mach;
4371     }
4372     return 0;
4373 }
4374
4375 package CPAN::Complete;
4376 use strict;
4377
4378 sub gnu_cpl {
4379     my($text, $line, $start, $end) = @_;
4380     my(@perlret) = cpl($text, $line, $start);
4381     # find longest common match. Can anybody show me how to peruse
4382     # T::R::Gnu to have this done automatically? Seems expensive.
4383     return () unless @perlret;
4384     my($newtext) = $text;
4385     for (my $i = length($text)+1;;$i++) {
4386         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4387         my $try = substr($perlret[0],0,$i);
4388         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4389         # warn "try[$try]tries[@tries]";
4390         if (@tries == @perlret) {
4391             $newtext = $try;
4392         } else {
4393             last;
4394         }
4395     }
4396     ($newtext,@perlret);
4397 }
4398
4399 #-> sub CPAN::Complete::cpl ;
4400 sub cpl {
4401     my($word,$line,$pos) = @_;
4402     $word ||= "";
4403     $line ||= "";
4404     $pos ||= 0;
4405     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4406     $line =~ s/^\s*//;
4407     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4408         $pos -= length($1);
4409     }
4410     my @return;
4411     if ($pos == 0) {
4412         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4413     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4414         @return = ();
4415     } elsif ($line =~ /^(a|ls)\s/) {
4416         @return = cplx('CPAN::Author',uc($word));
4417     } elsif ($line =~ /^b\s/) {
4418         CPAN::Shell->local_bundles;
4419         @return = cplx('CPAN::Bundle',$word);
4420     } elsif ($line =~ /^d\s/) {
4421         @return = cplx('CPAN::Distribution',$word);
4422     } elsif ($line =~ m/^(
4423                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4424                          )\s/x ) {
4425         if ($word =~ /^Bundle::/) {
4426             CPAN::Shell->local_bundles;
4427         }
4428         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4429     } elsif ($line =~ /^i\s/) {
4430         @return = cpl_any($word);
4431     } elsif ($line =~ /^reload\s/) {
4432         @return = cpl_reload($word,$line,$pos);
4433     } elsif ($line =~ /^o\s/) {
4434         @return = cpl_option($word,$line,$pos);
4435     } elsif ($line =~ m/^\S+\s/ ) {
4436         # fallback for future commands and what we have forgotten above
4437         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4438     } else {
4439         @return = ();
4440     }
4441     return @return;
4442 }
4443
4444 #-> sub CPAN::Complete::cplx ;
4445 sub cplx {
4446     my($class, $word) = @_;
4447     if (CPAN::_sqlite_running) {
4448         $CPAN::SQLite->search($class, "^\Q$word\E");
4449     }
4450     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4451 }
4452
4453 #-> sub CPAN::Complete::cpl_any ;
4454 sub cpl_any {
4455     my($word) = shift;
4456     return (
4457             cplx('CPAN::Author',$word),
4458             cplx('CPAN::Bundle',$word),
4459             cplx('CPAN::Distribution',$word),
4460             cplx('CPAN::Module',$word),
4461            );
4462 }
4463
4464 #-> sub CPAN::Complete::cpl_reload ;
4465 sub cpl_reload {
4466     my($word,$line,$pos) = @_;
4467     $word ||= "";
4468     my(@words) = split " ", $line;
4469     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4470     my(@ok) = qw(cpan index);
4471     return @ok if @words == 1;
4472     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4473 }
4474
4475 #-> sub CPAN::Complete::cpl_option ;
4476 sub cpl_option {
4477     my($word,$line,$pos) = @_;
4478     $word ||= "";
4479     my(@words) = split " ", $line;
4480     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4481     my(@ok) = qw(conf debug);
4482     return @ok if @words == 1;
4483     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4484     if (0) {
4485     } elsif ($words[1] eq 'index') {
4486         return ();
4487     } elsif ($words[1] eq 'conf') {
4488         return CPAN::HandleConfig::cpl(@_);
4489     } elsif ($words[1] eq 'debug') {
4490         return sort grep /^\Q$word\E/i,
4491             sort keys %CPAN::DEBUG, 'all';
4492     }
4493 }
4494
4495 package CPAN::Index;
4496 use strict;
4497
4498 #-> sub CPAN::Index::force_reload ;
4499 sub force_reload {
4500     my($class) = @_;
4501     $CPAN::Index::LAST_TIME = 0;
4502     $class->reload(1);
4503 }
4504
4505 #-> sub CPAN::Index::reload ;
4506 sub reload {
4507     my($self,$force) = @_;
4508     my $time = time;
4509
4510     # XXX check if a newer one is available. (We currently read it
4511     # from time to time)
4512     for ($CPAN::Config->{index_expire}) {
4513         $_ = 0.001 unless $_ && $_ > 0.001;
4514     }
4515     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4516         # debug here when CPAN doesn't seem to read the Metadata
4517         require Carp;
4518         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4519     }
4520     unless ($CPAN::META->{PROTOCOL}) {
4521         $self->read_metadata_cache;
4522         $CPAN::META->{PROTOCOL} ||= "1.0";
4523     }
4524     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4525         # warn "Setting last_time to 0";
4526         $LAST_TIME = 0; # No warning necessary
4527     }
4528     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4529         and ! $force){
4530         # called too often
4531         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4532     } elsif (0) {
4533         # IFF we are developing, it helps to wipe out the memory
4534         # between reloads, otherwise it is not what a user expects.
4535         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4536         $CPAN::META = CPAN->new;
4537     } else {
4538         my($debug,$t2);
4539         local $LAST_TIME = $time;
4540         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4541
4542         my $needshort = $^O eq "dos";
4543
4544         $self->rd_authindex($self
4545                           ->reload_x(
4546                                      "authors/01mailrc.txt.gz",
4547                                      $needshort ?
4548                                      File::Spec->catfile('authors', '01mailrc.gz') :
4549                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4550                                      $force));
4551         $t2 = time;
4552         $debug = "timing reading 01[".($t2 - $time)."]";
4553         $time = $t2;
4554         return if $CPAN::Signal; # this is sometimes lengthy
4555         $self->rd_modpacks($self
4556                          ->reload_x(
4557                                     "modules/02packages.details.txt.gz",
4558                                     $needshort ?
4559                                     File::Spec->catfile('modules', '02packag.gz') :
4560                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4561                                     $force));
4562         $t2 = time;
4563         $debug .= "02[".($t2 - $time)."]";
4564         $time = $t2;
4565         return if $CPAN::Signal; # this is sometimes lengthy
4566         $self->rd_modlist($self
4567                         ->reload_x(
4568                                    "modules/03modlist.data.gz",
4569                                    $needshort ?
4570                                    File::Spec->catfile('modules', '03mlist.gz') :
4571                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4572                                    $force));
4573         $self->write_metadata_cache;
4574         $t2 = time;
4575         $debug .= "03[".($t2 - $time)."]";
4576         $time = $t2;
4577         CPAN->debug($debug) if $CPAN::DEBUG;
4578     }
4579     if ($CPAN::Config->{build_dir_reuse}) {
4580         $self->reanimate_build_dir;
4581     }
4582     if (CPAN::_sqlite_running) {
4583         $CPAN::SQLite->reload(time => $time, force => $force)
4584             if not $LAST_TIME;
4585     }
4586     $LAST_TIME = $time;
4587     $CPAN::META->{PROTOCOL} = PROTOCOL;
4588 }
4589
4590 #-> sub CPAN::Index::reanimate_build_dir ;
4591 sub reanimate_build_dir {
4592     my($self) = @_;
4593     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4594         return;
4595     }
4596     return if $HAVE_REANIMATED++;
4597     my $d = $CPAN::Config->{build_dir};
4598     my $dh = DirHandle->new;
4599     opendir $dh, $d or return; # does not exist
4600     my $dirent;
4601     my $i = 0;
4602     my $painted = 0;
4603     my $restored = 0;
4604     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4605     my @candidates = map { $_->[0] }
4606         sort { $b->[1] <=> $a->[1] }
4607             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4608                 grep {/\.yml$/} readdir $dh;
4609   DISTRO: for $i (0..$#candidates) {
4610         my $dirent = $candidates[$i];
4611         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4612         if ($@) {
4613             warn "Error while parsing file '$dirent'; error: '$@'";
4614             next DISTRO;
4615         }
4616         my $c = $y->[0];
4617         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4618             my $key = $c->{distribution}{ID};
4619             for my $k (keys %{$c->{distribution}}) {
4620                 if ($c->{distribution}{$k}
4621                     && ref $c->{distribution}{$k}
4622                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4623                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4624                 }
4625             }
4626
4627             #we tried to restore only if element already
4628             #exists; but then we do not work with metadata
4629             #turned off.
4630             my $do
4631                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4632                     = $c->{distribution};
4633             for my $skipper (qw(badtestcnt notest force_update)) {
4634                 delete $do->{$skipper};
4635             }
4636             # $DB::single = 1;
4637             if ($do->{make_test}
4638                 && $do->{build_dir}
4639                 && !$do->{make_test}->failed
4640                 && (
4641                     !$do->{install}
4642                     ||
4643                     $do->{install}->failed
4644                    )
4645                ) {
4646                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4647             }
4648             $restored++;
4649         }
4650         $i++;
4651         while (($painted/76) < ($i/@candidates)) {
4652             $CPAN::Frontend->myprint(".");
4653             $painted++;
4654         }
4655     }
4656     $CPAN::Frontend->myprint(sprintf(
4657                                      "DONE\nFound %s old build%s, restored the state of %s\n",
4658                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4659                                      @candidates==1 ? "" : "s",
4660                                      $restored || "none",
4661                                     ));
4662 }
4663
4664
4665 #-> sub CPAN::Index::reload_x ;
4666 sub reload_x {
4667     my($cl,$wanted,$localname,$force) = @_;
4668     $force |= 2; # means we're dealing with an index here
4669     CPAN::HandleConfig->load; # we should guarantee loading wherever
4670                               # we rely on Config XXX
4671     $localname ||= $wanted;
4672     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4673                                          $localname);
4674     if (
4675         -f $abs_wanted &&
4676         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4677         !($force & 1)
4678        ) {
4679         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4680         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4681                    qq{day$s. I\'ll use that.});
4682         return $abs_wanted;
4683     } else {
4684         $force |= 1; # means we're quite serious about it.
4685     }
4686     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4687 }
4688
4689 #-> sub CPAN::Index::rd_authindex ;
4690 sub rd_authindex {
4691     my($cl, $index_target) = @_;
4692     return unless defined $index_target;
4693     return if CPAN::_sqlite_running;
4694     my @lines;
4695     $CPAN::Frontend->myprint("Going to read $index_target\n");
4696     local(*FH);
4697     tie *FH, 'CPAN::Tarzip', $index_target;
4698     local($/) = "\n";
4699     local($_);
4700     push @lines, split /\012/ while <FH>;
4701     my $i = 0;
4702     my $painted = 0;
4703     foreach (@lines) {
4704         my($userid,$fullname,$email) =
4705             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4706         $fullname ||= $email;
4707         if ($userid && $fullname && $email){
4708             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4709             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4710         } else {
4711             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4712         }
4713         $i++;
4714         while (($painted/76) < ($i/@lines)) {
4715             $CPAN::Frontend->myprint(".");
4716             $painted++;
4717         }
4718         return if $CPAN::Signal;
4719     }
4720     $CPAN::Frontend->myprint("DONE\n");
4721 }
4722
4723 sub userid {
4724   my($self,$dist) = @_;
4725   $dist = $self->{'id'} unless defined $dist;
4726   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4727   $ret;
4728 }
4729
4730 #-> sub CPAN::Index::rd_modpacks ;
4731 sub rd_modpacks {
4732     my($self, $index_target) = @_;
4733     return unless defined $index_target;
4734     return if CPAN::_sqlite_running;
4735     $CPAN::Frontend->myprint("Going to read $index_target\n");
4736     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4737     local $_;
4738     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4739     my $slurp = "";
4740     my $chunk;
4741     while (my $bytes = $fh->READ(\$chunk,8192)) {
4742         $slurp.=$chunk;
4743     }
4744     my @lines = split /\012/, $slurp;
4745     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4746     undef $fh;
4747     # read header
4748     my($line_count,$last_updated);
4749     while (@lines) {
4750         my $shift = shift(@lines);
4751         last if $shift =~ /^\s*$/;
4752         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4753         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4754     }
4755     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4756     if (not defined $line_count) {
4757
4758         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4759 Please check the validity of the index file by comparing it to more
4760 than one CPAN mirror. I'll continue but problems seem likely to
4761 happen.\a
4762 });
4763
4764         $CPAN::Frontend->mysleep(5);
4765     } elsif ($line_count != scalar @lines) {
4766
4767         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4768 contains a Line-Count header of %d but I see %d lines there. Please
4769 check the validity of the index file by comparing it to more than one
4770 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4771 $index_target, $line_count, scalar(@lines));
4772
4773     }
4774     if (not defined $last_updated) {
4775
4776         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4777 Please check the validity of the index file by comparing it to more
4778 than one CPAN mirror. I'll continue but problems seem likely to
4779 happen.\a
4780 });
4781
4782         $CPAN::Frontend->mysleep(5);
4783     } else {
4784
4785         $CPAN::Frontend
4786             ->myprint(sprintf qq{  Database was generated on %s\n},
4787                       $last_updated);
4788         $DATE_OF_02 = $last_updated;
4789
4790         my $age = time;
4791         if ($CPAN::META->has_inst('HTTP::Date')) {
4792             require HTTP::Date;
4793             $age -= HTTP::Date::str2time($last_updated);
4794         } else {
4795             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4796             require Time::Local;
4797             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4798             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4799             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4800         }
4801         $age /= 3600*24;
4802         if ($age > 30) {
4803
4804             $CPAN::Frontend
4805                 ->mywarn(sprintf
4806                          qq{Warning: This index file is %d days old.
4807   Please check the host you chose as your CPAN mirror for staleness.
4808   I'll continue but problems seem likely to happen.\a\n},
4809                          $age);
4810
4811         } elsif ($age < -1) {
4812
4813             $CPAN::Frontend
4814                 ->mywarn(sprintf
4815                          qq{Warning: Your system date is %d days behind this index file!
4816   System time:          %s
4817   Timestamp index file: %s
4818   Please fix your system time, problems with the make command expected.\n},
4819                          -$age,
4820                          scalar gmtime,
4821                          $DATE_OF_02,
4822                         );
4823
4824         }
4825     }
4826
4827
4828     # A necessity since we have metadata_cache: delete what isn't
4829     # there anymore
4830     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4831     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4832     my(%exists);
4833     my $i = 0;
4834     my $painted = 0;
4835     foreach (@lines) {
4836         # before 1.56 we split into 3 and discarded the rest. From
4837         # 1.57 we assign remaining text to $comment thus allowing to
4838         # influence isa_perl
4839         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4840         my($bundle,$id,$userid);
4841
4842         if ($mod eq 'CPAN' &&
4843             ! (
4844                CPAN::Queue->exists('Bundle::CPAN') ||
4845                CPAN::Queue->exists('CPAN')
4846               )
4847            ) {
4848             local($^W)= 0;
4849             if ($version > $CPAN::VERSION){
4850                 $CPAN::Frontend->mywarn(qq{
4851   New CPAN.pm version (v$version) available.
4852   [Currently running version is v$CPAN::VERSION]
4853   You might want to try
4854     install CPAN
4855     reload cpan
4856   to both upgrade CPAN.pm and run the new version without leaving
4857   the current session.
4858
4859 }); #});
4860                 $CPAN::Frontend->mysleep(2);
4861                 $CPAN::Frontend->myprint(qq{\n});
4862             }
4863             last if $CPAN::Signal;
4864         } elsif ($mod =~ /^Bundle::(.*)/) {
4865             $bundle = $1;
4866         }
4867
4868         if ($bundle){
4869             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4870             # Let's make it a module too, because bundles have so much
4871             # in common with modules.
4872
4873             # Changed in 1.57_63: seems like memory bloat now without
4874             # any value, so commented out
4875
4876             # $CPAN::META->instance('CPAN::Module',$mod);
4877
4878         } else {
4879
4880             # instantiate a module object
4881             $id = $CPAN::META->instance('CPAN::Module',$mod);
4882
4883         }
4884
4885         # Although CPAN prohibits same name with different version the
4886         # indexer may have changed the version for the same distro
4887         # since the last time ("Force Reindexing" feature)
4888         if ($id->cpan_file ne $dist
4889             ||
4890             $id->cpan_version ne $version
4891            ){
4892             $userid = $id->userid || $self->userid($dist);
4893             $id->set(
4894                      'CPAN_USERID' => $userid,
4895                      'CPAN_VERSION' => $version,
4896                      'CPAN_FILE' => $dist,
4897                     );
4898         }
4899
4900         # instantiate a distribution object
4901         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4902           # we do not need CONTAINSMODS unless we do something with
4903           # this dist, so we better produce it on demand.
4904
4905           ## my $obj = $CPAN::META->instance(
4906           ##                              'CPAN::Distribution' => $dist
4907           ##                             );
4908           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4909         } else {
4910           $CPAN::META->instance(
4911                                 'CPAN::Distribution' => $dist
4912                                )->set(
4913                                       'CPAN_USERID' => $userid,
4914                                       'CPAN_COMMENT' => $comment,
4915                                      );
4916         }
4917         if ($secondtime) {
4918             for my $name ($mod,$dist) {
4919                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4920                 $exists{$name} = undef;
4921             }
4922         }
4923         $i++;
4924         while (($painted/76) < ($i/@lines)) {
4925             $CPAN::Frontend->myprint(".");
4926             $painted++;
4927         }
4928         return if $CPAN::Signal;
4929     }
4930     $CPAN::Frontend->myprint("DONE\n");
4931     if ($secondtime) {
4932         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4933             for my $o ($CPAN::META->all_objects($class)) {
4934                 next if exists $exists{$o->{ID}};
4935                 $CPAN::META->delete($class,$o->{ID});
4936                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4937                 #     if $CPAN::DEBUG;
4938             }
4939         }
4940     }
4941 }
4942
4943 #-> sub CPAN::Index::rd_modlist ;
4944 sub rd_modlist {
4945     my($cl,$index_target) = @_;
4946     return unless defined $index_target;
4947     return if CPAN::_sqlite_running;
4948     $CPAN::Frontend->myprint("Going to read $index_target\n");
4949     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4950     local $_;
4951     my $slurp = "";
4952     my $chunk;
4953     while (my $bytes = $fh->READ(\$chunk,8192)) {
4954         $slurp.=$chunk;
4955     }
4956     my @eval2 = split /\012/, $slurp;
4957
4958     while (@eval2) {
4959         my $shift = shift(@eval2);
4960         if ($shift =~ /^Date:\s+(.*)/){
4961             if ($DATE_OF_03 eq $1){
4962                 $CPAN::Frontend->myprint("Unchanged.\n");
4963                 return;
4964             }
4965             ($DATE_OF_03) = $1;
4966         }
4967         last if $shift =~ /^\s*$/;
4968     }
4969     push @eval2, q{CPAN::Modulelist->data;};
4970     local($^W) = 0;
4971     my($comp) = Safe->new("CPAN::Safe1");
4972     my($eval2) = join("\n", @eval2);
4973     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4974     my $ret = $comp->reval($eval2);
4975     Carp::confess($@) if $@;
4976     return if $CPAN::Signal;
4977     my $i = 0;
4978     my $until = keys(%$ret);
4979     my $painted = 0;
4980     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4981     for (keys %$ret) {
4982         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4983         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4984         $obj->set(%{$ret->{$_}});
4985         $i++;
4986         while (($painted/76) < ($i/$until)) {
4987             $CPAN::Frontend->myprint(".");
4988             $painted++;
4989         }
4990         return if $CPAN::Signal;
4991     }
4992     $CPAN::Frontend->myprint("DONE\n");
4993 }
4994
4995 #-> sub CPAN::Index::write_metadata_cache ;
4996 sub write_metadata_cache {
4997     my($self) = @_;
4998     return unless $CPAN::Config->{'cache_metadata'};
4999     return if CPAN::_sqlite_running;
5000     return unless $CPAN::META->has_usable("Storable");
5001     my $cache;
5002     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5003                       CPAN::Distribution)) {
5004         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5005     }
5006     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5007     $cache->{last_time} = $LAST_TIME;
5008     $cache->{DATE_OF_02} = $DATE_OF_02;
5009     $cache->{PROTOCOL} = PROTOCOL;
5010     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5011     eval { Storable::nstore($cache, $metadata_file) };
5012     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5013 }
5014
5015 #-> sub CPAN::Index::read_metadata_cache ;
5016 sub read_metadata_cache {
5017     my($self) = @_;
5018     return unless $CPAN::Config->{'cache_metadata'};
5019     return if CPAN::_sqlite_running;
5020     return unless $CPAN::META->has_usable("Storable");
5021     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5022     return unless -r $metadata_file and -f $metadata_file;
5023     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5024     my $cache;
5025     eval { $cache = Storable::retrieve($metadata_file) };
5026     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5027     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
5028         $LAST_TIME = 0;
5029         return;
5030     }
5031     if (exists $cache->{PROTOCOL}) {
5032         if (PROTOCOL > $cache->{PROTOCOL}) {
5033             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5034                                             "with protocol v%s, requiring v%s\n",
5035                                             $cache->{PROTOCOL},
5036                                             PROTOCOL)
5037                                    );
5038             return;
5039         }
5040     } else {
5041         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5042                                 "with protocol v1.0\n");
5043         return;
5044     }
5045     my $clcnt = 0;
5046     my $idcnt = 0;
5047     while(my($class,$v) = each %$cache) {
5048         next unless $class =~ /^CPAN::/;
5049         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5050         while (my($id,$ro) = each %$v) {
5051             $CPAN::META->{readwrite}{$class}{$id} ||=
5052                 $class->new(ID=>$id, RO=>$ro);
5053             $idcnt++;
5054         }
5055         $clcnt++;
5056     }
5057     unless ($clcnt) { # sanity check
5058         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5059         return;
5060     }
5061     if ($idcnt < 1000) {
5062         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5063                                  "in $metadata_file\n");
5064         return;
5065     }
5066     $CPAN::META->{PROTOCOL} ||=
5067         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5068                             # does initialize to some protocol
5069     $LAST_TIME = $cache->{last_time};
5070     $DATE_OF_02 = $cache->{DATE_OF_02};
5071     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5072         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5073     return;
5074 }
5075
5076 package CPAN::InfoObj;
5077 use strict;
5078
5079 sub ro {
5080     my $self = shift;
5081     exists $self->{RO} and return $self->{RO};
5082 }
5083
5084 #-> sub CPAN::InfoObj::cpan_userid
5085 sub cpan_userid {
5086     my $self = shift;
5087     my $ro = $self->ro;
5088     if ($ro) {
5089         return $ro->{CPAN_USERID} || "N/A";
5090     } else {
5091         $self->debug("ID[$self->{ID}]");
5092         # N/A for bundles found locally
5093         return "N/A";
5094     }
5095 }
5096
5097 sub id { shift->{ID}; }
5098
5099 #-> sub CPAN::InfoObj::new ;
5100 sub new {
5101     my $this = bless {}, shift;
5102     %$this = @_;
5103     $this
5104 }
5105
5106 # The set method may only be used by code that reads index data or
5107 # otherwise "objective" data from the outside world. All session
5108 # related material may do anything else with instance variables but
5109 # must not touch the hash under the RO attribute. The reason is that
5110 # the RO hash gets written to Metadata file and is thus persistent.
5111
5112 #-> sub CPAN::InfoObj::safe_chdir ;
5113 sub safe_chdir {
5114   my($self,$todir) = @_;
5115   # we die if we cannot chdir and we are debuggable
5116   Carp::confess("safe_chdir called without todir argument")
5117         unless defined $todir and length $todir;
5118   if (chdir $todir) {
5119     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5120         if $CPAN::DEBUG;
5121   } else {
5122     if (-e $todir) {
5123         unless (-x $todir) {
5124             unless (chmod 0755, $todir) {
5125                 my $cwd = CPAN::anycwd();
5126                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5127                                         "permission to change the permission; cannot ".
5128                                         "chdir to '$todir'\n");
5129                 $CPAN::Frontend->mysleep(5);
5130                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5131                                        qq{to todir[$todir]: $!});
5132             }
5133         }
5134     } else {
5135         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5136     }
5137     if (chdir $todir) {
5138       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5139           if $CPAN::DEBUG;
5140     } else {
5141       my $cwd = CPAN::anycwd();
5142       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5143                              qq{to todir[$todir] (a chmod has been issued): $!});
5144     }
5145   }
5146 }
5147
5148 #-> sub CPAN::InfoObj::set ;
5149 sub set {
5150     my($self,%att) = @_;
5151     my $class = ref $self;
5152
5153     # This must be ||=, not ||, because only if we write an empty
5154     # reference, only then the set method will write into the readonly
5155     # area. But for Distributions that spring into existence, maybe
5156     # because of a typo, we do not like it that they are written into
5157     # the readonly area and made permanent (at least for a while) and
5158     # that is why we do not "allow" other places to call ->set.
5159     unless ($self->id) {
5160         CPAN->debug("Bug? Empty ID, rejecting");
5161         return;
5162     }
5163     my $ro = $self->{RO} =
5164         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5165
5166     while (my($k,$v) = each %att) {
5167         $ro->{$k} = $v;
5168     }
5169 }
5170
5171 #-> sub CPAN::InfoObj::as_glimpse ;
5172 sub as_glimpse {
5173     my($self) = @_;
5174     my(@m);
5175     my $class = ref($self);
5176     $class =~ s/^CPAN:://;
5177     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5178     push @m, sprintf "%-15s %s\n", $class, $id;
5179     join "", @m;
5180 }
5181
5182 #-> sub CPAN::InfoObj::as_string ;
5183 sub as_string {
5184     my($self) = @_;
5185     my(@m);
5186     my $class = ref($self);
5187     $class =~ s/^CPAN:://;
5188     push @m, $class, " id = $self->{ID}\n";
5189     my $ro;
5190     unless ($ro = $self->ro) {
5191         if (substr($self->{ID},-1,1) eq ".") { # directory
5192             $ro = +{};
5193         } else {
5194             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5195         }
5196     }
5197     for (sort keys %$ro) {
5198         # next if m/^(ID|RO)$/;
5199         my $extra = "";
5200         if ($_ eq "CPAN_USERID") {
5201             $extra .= " (";
5202             $extra .= $self->fullname;
5203             my $email; # old perls!
5204             if ($email = $CPAN::META->instance("CPAN::Author",
5205                                                $self->cpan_userid
5206                                               )->email) {
5207                 $extra .= " <$email>";
5208             } else {
5209                 $extra .= " <no email>";
5210             }
5211             $extra .= ")";
5212         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5213             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5214             next;
5215         }
5216         next unless defined $ro->{$_};
5217         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5218     }
5219   KEY: for (sort keys %$self) {
5220         next if m/^(ID|RO)$/;
5221         unless (defined $self->{$_}) {
5222             delete $self->{$_};
5223             next KEY;
5224         }
5225         if (ref($self->{$_}) eq "ARRAY") {
5226           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5227         } elsif (ref($self->{$_}) eq "HASH") {
5228             my $value;
5229             if (/^CONTAINSMODS$/) {
5230                 $value = join(" ",sort keys %{$self->{$_}});
5231             } elsif (/^prereq_pm$/) {
5232                 my @value;
5233                 my $v = $self->{$_};
5234                 for my $x (sort keys %$v) {
5235                     my @svalue;
5236                     for my $y (sort keys %{$v->{$x}}) {
5237                         push @svalue, "$y=>$v->{$x}{$y}";
5238                     }
5239                     push @value, "$x\:" . join ",", @svalue if @svalue;
5240                 }
5241                 $value = join ";", @value;
5242             } else {
5243                 $value = $self->{$_};
5244             }
5245           push @m, sprintf(
5246                            "    %-12s %s\n",
5247                            $_,
5248                            $value,
5249                           );
5250         } else {
5251           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5252         }
5253     }
5254     join "", @m, "\n";
5255 }
5256
5257 #-> sub CPAN::InfoObj::fullname ;
5258 sub fullname {
5259     my($self) = @_;
5260     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5261 }
5262
5263 #-> sub CPAN::InfoObj::dump ;
5264 sub dump {
5265   my($self, $what) = @_;
5266   unless ($CPAN::META->has_inst("Data::Dumper")) {
5267       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5268   }
5269   local $Data::Dumper::Sortkeys;
5270   $Data::Dumper::Sortkeys = 1;
5271   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5272   if (length $out > 100000) {
5273       my $fh_pager = FileHandle->new;
5274       local($SIG{PIPE}) = "IGNORE";
5275       my $pager = $CPAN::Config->{'pager'} || "cat";
5276       $fh_pager->open("|$pager")
5277           or die "Could not open pager $pager\: $!";
5278       $fh_pager->print($out);
5279       close $fh_pager;
5280   } else {
5281       $CPAN::Frontend->myprint($out);
5282   }
5283 }
5284
5285 package CPAN::Author;
5286 use strict;
5287
5288 #-> sub CPAN::Author::force
5289 sub force {
5290     my $self = shift;
5291     $self->{force}++;
5292 }
5293
5294 #-> sub CPAN::Author::force
5295 sub unforce {
5296     my $self = shift;
5297     delete $self->{force};
5298 }
5299
5300 #-> sub CPAN::Author::id
5301 sub id {
5302     my $self = shift;
5303     my $id = $self->{ID};
5304     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5305     $id;
5306 }
5307
5308 #-> sub CPAN::Author::as_glimpse ;
5309 sub as_glimpse {
5310     my($self) = @_;
5311     my(@m);
5312     my $class = ref($self);
5313     $class =~ s/^CPAN:://;
5314     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5315                      $class,
5316                      $self->{ID},
5317                      $self->fullname,
5318                      $self->email);
5319     join "", @m;
5320 }
5321
5322 #-> sub CPAN::Author::fullname ;
5323 sub fullname {
5324     shift->ro->{FULLNAME};
5325 }
5326 *name = \&fullname;
5327
5328 #-> sub CPAN::Author::email ;
5329 sub email    { shift->ro->{EMAIL}; }
5330
5331 #-> sub CPAN::Author::ls ;
5332 sub ls {
5333     my $self = shift;
5334     my $glob = shift || "";
5335     my $silent = shift || 0;
5336     my $id = $self->id;
5337
5338     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5339     my(@csf); # chksumfile
5340     @csf = $self->id =~ /(.)(.)(.*)/;
5341     $csf[1] = join "", @csf[0,1];
5342     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5343     my(@dl);
5344     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5345     unless (grep {$_->[2] eq $csf[1]} @dl) {
5346         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5347         return;
5348     }
5349     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5350     unless (grep {$_->[2] eq $csf[2]} @dl) {
5351         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5352         return;
5353     }
5354     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5355     if ($glob) {
5356         if ($CPAN::META->has_inst("Text::Glob")) {
5357             my $rglob = Text::Glob::glob_to_regex($glob);
5358             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5359         } else {
5360             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5361         }
5362     }
5363     $CPAN::Frontend->myprint(join "", map {
5364         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5365     } sort { $a->[2] cmp $b->[2] } @dl);
5366     @dl;
5367 }
5368
5369 # returns an array of arrays, the latter contain (size,mtime,filename)
5370 #-> sub CPAN::Author::dir_listing ;
5371 sub dir_listing {
5372     my $self = shift;
5373     my $chksumfile = shift;
5374     my $recursive = shift;
5375     my $may_ftp = shift;
5376
5377     my $lc_want =
5378         File::Spec->catfile($CPAN::Config->{keep_source_where},
5379                             "authors", "id", @$chksumfile);
5380
5381     my $fh;
5382
5383     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5384     # hazard.  (Without GPG installed they are not that much better,
5385     # though.)
5386     $fh = FileHandle->new;
5387     if (open($fh, $lc_want)) {
5388         my $line = <$fh>; close $fh;
5389         unlink($lc_want) unless $line =~ /PGP/;
5390     }
5391
5392     local($") = "/";
5393     # connect "force" argument with "index_expire".
5394     my $force = $self->{force};
5395     if (my @stat = stat $lc_want) {
5396         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5397     }
5398     my $lc_file;
5399     if ($may_ftp) {
5400         $lc_file = CPAN::FTP->localize(
5401                                        "authors/id/@$chksumfile",
5402                                        $lc_want,
5403                                        $force,
5404                                       );
5405         unless ($lc_file) {
5406             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5407             $chksumfile->[-1] .= ".gz";
5408             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5409                                            "$lc_want.gz",1);
5410             if ($lc_file) {
5411                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5412                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5413             } else {
5414                 return;
5415             }
5416         }
5417     } else {
5418         $lc_file = $lc_want;
5419         # we *could* second-guess and if the user has a file: URL,
5420         # then we could look there. But on the other hand, if they do
5421         # have a file: URL, wy did they choose to set
5422         # $CPAN::Config->{show_upload_date} to false?
5423     }
5424
5425     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5426     $fh = FileHandle->new;
5427     my($cksum);
5428     if (open $fh, $lc_file){
5429         local($/);
5430         my $eval = <$fh>;
5431         $eval =~ s/\015?\012/\n/g;
5432         close $fh;
5433         my($comp) = Safe->new();
5434         $cksum = $comp->reval($eval);
5435         if ($@) {
5436             rename $lc_file, "$lc_file.bad";
5437             Carp::confess($@) if $@;
5438         }
5439     } elsif ($may_ftp) {
5440         Carp::carp "Could not open '$lc_file' for reading.";
5441     } else {
5442         # Maybe should warn: "You may want to set show_upload_date to a true value"
5443         return;
5444     }
5445     my(@result,$f);
5446     for $f (sort keys %$cksum) {
5447         if (exists $cksum->{$f}{isdir}) {
5448             if ($recursive) {
5449                 my(@dir) = @$chksumfile;
5450                 pop @dir;
5451                 push @dir, $f, "CHECKSUMS";
5452                 push @result, map {
5453                     [$_->[0], $_->[1], "$f/$_->[2]"]
5454                 } $self->dir_listing(\@dir,1,$may_ftp);
5455             } else {
5456                 push @result, [ 0, "-", $f ];
5457             }
5458         } else {
5459             push @result, [
5460                            ($cksum->{$f}{"size"}||0),
5461                            $cksum->{$f}{"mtime"}||"---",
5462                            $f
5463                           ];
5464         }
5465     }
5466     @result;
5467 }
5468
5469 #-> sub CPAN::Author::reports
5470 sub reports {
5471     $CPAN::Frontend->mywarn("reports on authors not implemented.
5472 Please file a bugreport if you need this.\n");
5473 }
5474
5475 package CPAN::Distribution;
5476 use strict;
5477
5478 # Accessors
5479 sub cpan_comment {
5480     my $self = shift;
5481     my $ro = $self->ro or return;
5482     $ro->{CPAN_COMMENT}
5483 }
5484
5485 #-> CPAN::Distribution::undelay
5486 sub undelay {
5487     my $self = shift;
5488     delete $self->{later};
5489 }
5490
5491 #-> CPAN::Distribution::is_dot_dist
5492 sub is_dot_dist {
5493     my($self) = @_;
5494     return (
5495             substr($self->id,-1,1) eq "."
5496             ||
5497             $self->author->id eq "LOCAL"
5498            );
5499 }
5500
5501 # add the A/AN/ stuff
5502 #-> CPAN::Distribution::normalize
5503 sub normalize {
5504     my($self,$s) = @_;
5505     $s = $self->id unless defined $s;
5506     if (substr($s,-1,1) eq ".") {
5507         # using a global because we are sometimes called as static method
5508         if (!$CPAN::META->{LOCK}
5509             && !$CPAN::Have_warned->{"$s is unlocked"}++
5510            ) {
5511             $CPAN::Frontend->mywarn("You are visiting the local directory
5512   '$s'
5513   without lock, take care that concurrent processes do not do likewise.\n");
5514             $CPAN::Frontend->mysleep(1);
5515         }
5516         if ($s eq ".") {
5517             $s = "$CPAN::iCwd/.";
5518         } elsif (File::Spec->file_name_is_absolute($s)) {
5519         } elsif (File::Spec->can("rel2abs")) {
5520             $s = File::Spec->rel2abs($s);
5521         } else {
5522             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5523         }
5524         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5525         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5526             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5527                 $_->{build_dir} = $s;
5528                 $_->{archived} = "local_directory";
5529                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5530             }
5531         }
5532     } elsif (
5533         $s =~ tr|/|| == 1
5534         or
5535         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5536        ) {
5537         return $s if $s =~ m:^N/A|^Contact Author: ;
5538         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5539             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5540         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5541     }
5542     $s;
5543 }
5544
5545 #-> sub CPAN::Distribution::author ;
5546 sub author {
5547     my($self) = @_;
5548     my($authorid);
5549     if (substr($self->id,-1,1) eq ".") {
5550         $authorid = "LOCAL";
5551     } else {
5552         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5553     }
5554     CPAN::Shell->expand("Author",$authorid);
5555 }
5556
5557 # tries to get the yaml from CPAN instead of the distro itself:
5558 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5559 sub fast_yaml {
5560     my($self) = @_;
5561     my $meta = $self->pretty_id;
5562     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5563     my(@ls) = CPAN::Shell->globls($meta);
5564     my $norm = $self->normalize($meta);
5565
5566     my($local_file);
5567     my($local_wanted) =
5568         File::Spec->catfile(
5569                             $CPAN::Config->{keep_source_where},
5570                             "authors",
5571                             "id",
5572                             split(/\//,$norm)
5573                            );
5574     $self->debug("Doing localize") if $CPAN::DEBUG;
5575     unless ($local_file =
5576             CPAN::FTP->localize("authors/id/$norm",
5577                                 $local_wanted)) {
5578         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5579     }
5580     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5581 }
5582
5583 #-> sub CPAN::Distribution::cpan_userid
5584 sub cpan_userid {
5585     my $self = shift;
5586     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5587         return $1;
5588     }
5589     return $self->SUPER::cpan_userid;
5590 }
5591
5592 #-> sub CPAN::Distribution::pretty_id
5593 sub pretty_id {
5594     my $self = shift;
5595     my $id = $self->id;
5596     return $id unless $id =~ m|^./../|;
5597     substr($id,5);
5598 }
5599
5600 # mark as dirty/clean for the sake of recursion detection. $color=1
5601 # means "in use", $color=0 means "not in use anymore". $color=2 means
5602 # we have determined prereqs now and thus insist on passing this
5603 # through (at least) once again.
5604
5605 #-> sub CPAN::Distribution::color_cmd_tmps ;
5606 sub color_cmd_tmps {
5607     my($self) = shift;
5608     my($depth) = shift || 0;
5609     my($color) = shift || 0;
5610     my($ancestors) = shift || [];
5611     # a distribution needs to recurse into its prereq_pms
5612
5613     return if exists $self->{incommandcolor}
5614         && $color==1
5615         && $self->{incommandcolor}==$color;
5616     if ($depth>=$CPAN::MAX_RECURSION){
5617         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5618     }
5619     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5620     my $prereq_pm = $self->prereq_pm;
5621     if (defined $prereq_pm) {
5622       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5623                            keys %{$prereq_pm->{build_requires}||{}}) {
5624             next PREREQ if $pre eq "perl";
5625             my $premo;
5626             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5627                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5628                 $CPAN::Frontend->mysleep(2);
5629                 next PREREQ;
5630             }
5631             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5632         }
5633     }
5634     if ($color==0) {
5635         delete $self->{sponsored_mods};
5636
5637         # as we are at the end of a command, we'll give up this
5638         # reminder of a broken test. Other commands may test this guy
5639         # again. Maybe 'badtestcnt' should be renamed to
5640         # 'make_test_failed_within_command'?
5641         delete $self->{badtestcnt};
5642     }
5643     $self->{incommandcolor} = $color;
5644 }
5645
5646 #-> sub CPAN::Distribution::as_string ;
5647 sub as_string {
5648   my $self = shift;
5649   $self->containsmods;
5650   $self->upload_date;
5651   $self->SUPER::as_string(@_);
5652 }
5653
5654 #-> sub CPAN::Distribution::containsmods ;
5655 sub containsmods {
5656   my $self = shift;
5657   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5658   my $dist_id = $self->{ID};
5659   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5660     my $mod_file = $mod->cpan_file or next;
5661     my $mod_id = $mod->{ID} or next;
5662     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5663     # sleep 1;
5664     if ($CPAN::Signal) {
5665         delete $self->{CONTAINSMODS};
5666         return;
5667     }
5668     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5669   }
5670   keys %{$self->{CONTAINSMODS}||{}};
5671 }
5672
5673 #-> sub CPAN::Distribution::upload_date ;
5674 sub upload_date {
5675   my $self = shift;
5676   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5677   my(@local_wanted) = split(/\//,$self->id);
5678   my $filename = pop @local_wanted;
5679   push @local_wanted, "CHECKSUMS";
5680   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5681   return unless $author;
5682   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5683   return unless @dl;
5684   my($dirent) = grep { $_->[2] eq $filename } @dl;
5685   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5686   return unless $dirent->[1];
5687   return $self->{UPLOAD_DATE} = $dirent->[1];
5688 }
5689
5690 #-> sub CPAN::Distribution::uptodate ;
5691 sub uptodate {
5692     my($self) = @_;
5693     my $c;
5694     foreach $c ($self->containsmods) {
5695         my $obj = CPAN::Shell->expandany($c);
5696         unless ($obj->uptodate){
5697             my $id = $self->pretty_id;
5698             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5699             return 0;
5700         }
5701     }
5702     return 1;
5703 }
5704
5705 #-> sub CPAN::Distribution::called_for ;
5706 sub called_for {
5707     my($self,$id) = @_;
5708     $self->{CALLED_FOR} = $id if defined $id;
5709     return $self->{CALLED_FOR};
5710 }
5711
5712 #-> sub CPAN::Distribution::get ;
5713 sub get {
5714     my($self) = @_;
5715     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5716     if (my $goto = $self->prefs->{goto}) {
5717         $CPAN::Frontend->mywarn
5718             (sprintf(
5719                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5720                      $goto,
5721                      $self->{prefs_file},
5722                      $self->{prefs_file_doc},
5723                     ));
5724         return $self->goto($goto);
5725     }
5726     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5727                            ? $ENV{PERL5LIB}
5728                            : ($ENV{PERLLIB} || "");
5729
5730     $CPAN::META->set_perl5lib;
5731     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5732
5733   EXCUSE: {
5734         my @e;
5735         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5736         if ($self->prefs->{disabled}) {
5737             my $why = sprintf(
5738                               "Disabled via prefs file '%s' doc %d",
5739                               $self->{prefs_file},
5740                               $self->{prefs_file_doc},
5741                              );
5742             push @e, $why;
5743             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5744             # note: not intended to be persistent but at least visible
5745             # during this session
5746         } else {
5747             if (exists $self->{build_dir} && -d $self->{build_dir}
5748                 && ($self->{modulebuild}||$self->{writemakefile})
5749                ) {
5750                 # this deserves print, not warn:
5751                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5752                                          "$self->{build_dir}\n"
5753                                         );
5754                 return 1;
5755             }
5756
5757             # although we talk about 'force' we shall not test on
5758             # force directly. New model of force tries to refrain from
5759             # direct checking of force.
5760             exists $self->{unwrapped} and (
5761                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5762                                            $self->{unwrapped}->failed :
5763                                            $self->{unwrapped} =~ /^NO/
5764                                           )
5765                 and push @e, "Unwrapping had some problem, won't try again without force";
5766         }
5767
5768         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5769     }
5770     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5771
5772     $self->get_file_onto_local_disk;
5773     return if $CPAN::Signal;
5774     $self->check_integrity;
5775     return if $CPAN::Signal;
5776     my($packagedir,$local_file) = $self->run_preps_on_packagedir;
5777     $packagedir ||= $self->{build_dir};
5778
5779     if ($CPAN::Signal){
5780         $self->safe_chdir($sub_wd);
5781         return;
5782     }
5783     return $self->run_MM_or_MB($local_file,$packagedir);
5784 }
5785
5786 #-> CPAN::Distribution::get_file_onto_local_disk
5787 sub get_file_onto_local_disk {
5788     my($self) = @_;
5789
5790     return if $self->is_dot_dist;
5791     my($local_file);
5792     my($local_wanted) =
5793         File::Spec->catfile(
5794                             $CPAN::Config->{keep_source_where},
5795                             "authors",
5796                             "id",
5797                             split(/\//,$self->id)
5798                            );
5799
5800     $self->debug("Doing localize") if $CPAN::DEBUG;
5801     unless ($local_file =
5802             CPAN::FTP->localize("authors/id/$self->{ID}",
5803                                 $local_wanted)) {
5804         my $note = "";
5805         if ($CPAN::Index::DATE_OF_02) {
5806             $note = "Note: Current database in memory was generated ".
5807                 "on $CPAN::Index::DATE_OF_02\n";
5808         }
5809         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5810     }
5811
5812     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5813     $self->{localfile} = $local_file;
5814 }
5815
5816
5817 #-> CPAN::Distribution::check_integrity
5818 sub check_integrity {
5819     my($self) = @_;
5820
5821     return if $self->is_dot_dist;
5822     if ($CPAN::META->has_inst("Digest::SHA")) {
5823         $self->debug("Digest::SHA is installed, verifying");
5824         $self->verifyCHECKSUM;
5825     } else {
5826         $self->debug("Digest::SHA is NOT installed");
5827     }
5828 }
5829
5830 #-> CPAN::Distribution::run_preps_on_packagedir
5831 sub run_preps_on_packagedir {
5832     my($self) = @_;
5833     return if $self->is_dot_dist;
5834
5835     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5836     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5837     $self->safe_chdir($builddir);
5838     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5839     File::Path::rmtree("tmp-$$");
5840     unless (mkdir "tmp-$$", 0755) {
5841         $CPAN::Frontend->unrecoverable_error(<<EOF);
5842 Couldn't mkdir '$builddir/tmp-$$': $!
5843
5844 Cannot continue: Please find the reason why I cannot make the
5845 directory
5846 $builddir/tmp-$$
5847 and fix the problem, then retry.
5848
5849 EOF
5850     }
5851     if ($CPAN::Signal){
5852         return;
5853     }
5854     $self->safe_chdir("tmp-$$");
5855
5856     #
5857     # Unpack the goods
5858     #
5859     my $local_file = $self->{localfile};
5860     my $ct = eval{CPAN::Tarzip->new($local_file)};
5861     unless ($ct) {
5862         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5863         delete $self->{build_dir};
5864         return;
5865     }
5866     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5867         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5868         $self->untar_me($ct);
5869     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5870         $self->unzip_me($ct);
5871     } else {
5872         $self->{was_uncompressed}++ unless $ct->gtest();
5873         $local_file = $self->handle_singlefile($local_file);
5874     }
5875
5876     # we are still in the tmp directory!
5877     # Let's check if the package has its own directory.
5878     my $dh = DirHandle->new(File::Spec->curdir)
5879         or Carp::croak("Couldn't opendir .: $!");
5880     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5881     $dh->close;
5882     my ($packagedir);
5883     # XXX here we want in each branch File::Temp to protect all build_dir directories
5884     if (CPAN->has_inst("File::Temp")) {
5885         my $tdir_base;
5886         my $from_dir;
5887         my @dirents;
5888         if (@readdir == 1 && -d $readdir[0]) {
5889             $tdir_base = $readdir[0];
5890             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5891             my $dh2 = DirHandle->new($from_dir)
5892                 or Carp::croak("Couldn't opendir $from_dir: $!");
5893             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5894         } else {
5895             my $userid = $self->cpan_userid;
5896             CPAN->debug("userid[$userid]");
5897             if (!$userid or $userid eq "N/A") {
5898                 $userid = "anon";
5899             }
5900             $tdir_base = $userid;
5901             $from_dir = File::Spec->curdir;
5902             @dirents = @readdir;
5903         }
5904         $packagedir = File::Temp::tempdir(
5905                                           "$tdir_base-XXXXXX",
5906                                           DIR => $builddir,
5907                                           CLEANUP => 0,
5908                                          );
5909         my $f;
5910         for $f (@dirents) { # is already without "." and ".."
5911             my $from = File::Spec->catdir($from_dir,$f);
5912             my $to = File::Spec->catdir($packagedir,$f);
5913             unless (File::Copy::move($from,$to)) {
5914                 my $err = $!;
5915                 $from = File::Spec->rel2abs($from);
5916                 Carp::confess("Couldn't move $from to $to: $err");
5917             }
5918         }
5919     } else { # older code below, still better than nothing when there is no File::Temp
5920         my($distdir);
5921         if (@readdir == 1 && -d $readdir[0]) {
5922             $distdir = $readdir[0];
5923             $packagedir = File::Spec->catdir($builddir,$distdir);
5924             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5925                 if $CPAN::DEBUG;
5926             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5927                                                         "$packagedir\n");
5928             File::Path::rmtree($packagedir);
5929             unless (File::Copy::move($distdir,$packagedir)) {
5930                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5931 Couldn't move '$distdir' to '$packagedir': $!
5932
5933 Cannot continue: Please find the reason why I cannot move
5934 $builddir/tmp-$$/$distdir
5935 to
5936 $packagedir
5937 and fix the problem, then retry
5938
5939 EOF
5940             }
5941             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5942                                  $distdir,
5943                                  $packagedir,
5944                                  -e $packagedir,
5945                                  -d $packagedir,
5946                                 )) if $CPAN::DEBUG;
5947         } else {
5948             my $userid = $self->cpan_userid;
5949             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5950             if (!$userid or $userid eq "N/A") {
5951                 $userid = "anon";
5952             }
5953             my $pragmatic_dir = $userid . '000';
5954             $pragmatic_dir =~ s/\W_//g;
5955             $pragmatic_dir++ while -d "../$pragmatic_dir";
5956             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5957             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5958             File::Path::mkpath($packagedir);
5959             my($f);
5960             for $f (@readdir) { # is already without "." and ".."
5961                 my $to = File::Spec->catdir($packagedir,$f);
5962                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5963             }
5964         }
5965     }
5966     $self->{build_dir} = $packagedir;
5967     $self->safe_chdir($builddir);
5968     File::Path::rmtree("tmp-$$");
5969
5970     $self->safe_chdir($packagedir);
5971     $self->_signature_business();
5972     $self->safe_chdir($builddir);
5973
5974     return($packagedir,$local_file);
5975 }
5976
5977 #-> sub CPAN::Distribution::run_MM_or_MB
5978 sub run_MM_or_MB {
5979     my($self,$local_file,$packagedir) = @_;
5980     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5981     my($mpl_exists) = -f $mpl;
5982     unless ($mpl_exists) {
5983         # NFS has been reported to have racing problems after the
5984         # renaming of a directory in some environments.
5985         # This trick helps.
5986         $CPAN::Frontend->mysleep(1);
5987         my $mpldh = DirHandle->new($packagedir)
5988             or Carp::croak("Couldn't opendir $packagedir: $!");
5989         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5990         $mpldh->close;
5991     }
5992     my $prefer_installer = "eumm"; # eumm|mb
5993     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5994         if ($mpl_exists) { # they *can* choose
5995             if ($CPAN::META->has_inst("Module::Build")) {
5996                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5997                                                                      q{prefer_installer});
5998             }
5999         } else {
6000             $prefer_installer = "mb";
6001         }
6002     }
6003     return unless $self->patch;
6004     if (lc($prefer_installer) eq "mb") {
6005         $self->{modulebuild} = 1;
6006     } elsif ($self->{archived} eq "patch") {
6007         # not an edge case, nothing to install for sure
6008         my $why = "A patch file cannot be installed";
6009         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6010         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6011     } elsif (! $mpl_exists) {
6012         $self->_edge_cases($mpl,$packagedir,$local_file);
6013     }
6014     if ($self->{build_dir}
6015         &&
6016         $CPAN::Config->{build_dir_reuse}
6017        ) {
6018         $self->store_persistent_state;
6019     }
6020     return $self;
6021 }
6022
6023 #-> CPAN::Distribution::store_persistent_state
6024 sub store_persistent_state {
6025     my($self) = @_;
6026     my $dir = $self->{build_dir};
6027     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6028             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6029         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6030                                 "will not store persistent state\n");
6031         return;
6032     }
6033     my $file = sprintf "%s.yml", $dir;
6034     my $yaml_module = CPAN::_yaml_module;
6035     if ($CPAN::META->has_inst($yaml_module)) {
6036         CPAN->_yaml_dumpfile(
6037                              $file,
6038                              {
6039                               time => time,
6040                               perl => CPAN::_perl_fingerprint,
6041                               distribution => $self,
6042                              }
6043                             );
6044     } else {
6045         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6046                                 "will not store persistent state\n");
6047     }
6048 }
6049
6050 #-> CPAN::Distribution::patch
6051 sub try_download {
6052     my($self,$patch) = @_;
6053     my $norm = $self->normalize($patch);
6054     my($local_wanted) =
6055         File::Spec->catfile(
6056                             $CPAN::Config->{keep_source_where},
6057                             "authors",
6058                             "id",
6059                             split(/\//,$norm),
6060                             );
6061     $self->debug("Doing localize") if $CPAN::DEBUG;
6062     return CPAN::FTP->localize("authors/id/$norm",
6063                                $local_wanted);
6064 }
6065
6066 #-> CPAN::Distribution::patch
6067 sub patch {
6068     my($self) = @_;
6069     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6070     my $patches = $self->prefs->{patches};
6071     $patches ||= "";
6072     $self->debug("patches[$patches]") if $CPAN::DEBUG;
6073     if ($patches) {
6074         return unless @$patches;
6075         $self->safe_chdir($self->{build_dir});
6076         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6077         my $patchbin = $CPAN::Config->{patch};
6078         unless ($patchbin && length $patchbin) {
6079             $CPAN::Frontend->mydie("No external patch command configured\n\n".
6080                                    "Please run 'o conf init /patch/'\n\n");
6081         }
6082         unless (MM->maybe_command($patchbin)) {
6083             $CPAN::Frontend->mydie("No external patch command available\n\n".
6084                                    "Please run 'o conf init /patch/'\n\n");
6085         }
6086         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6087         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
6088                                    # supported everywhere (and then,
6089                                    # not ever necessary there)
6090         my $stdpatchargs = "-N --fuzz=3";
6091         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6092         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6093         for my $patch (@$patches) {
6094             unless (-f $patch) {
6095                 if (my $trydl = $self->try_download($patch)) {
6096                     $patch = $trydl;
6097                 } else {
6098                     my $fail = "Could not find patch '$patch'";
6099                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6100                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6101                     delete $self->{build_dir};
6102                     return;
6103                 }
6104             }
6105             $CPAN::Frontend->myprint("  $patch\n");
6106             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6107
6108             my $pcommand;
6109             my $ppp = $self->_patch_p_parameter($readfh);
6110             if ($ppp eq "applypatch") {
6111                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6112             } else {
6113                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6114                 $pcommand = "$patchbin $thispatchargs";
6115             }
6116
6117             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6118             my $writefh = FileHandle->new;
6119             $CPAN::Frontend->myprint("  $pcommand\n");
6120             unless (open $writefh, "|$pcommand") {
6121                 my $fail = "Could not fork '$pcommand'";
6122                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6123                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6124                 delete $self->{build_dir};
6125                 return;
6126             }
6127             while (my $x = $readfh->READLINE) {
6128                 print $writefh $x;
6129             }
6130             unless (close $writefh) {
6131                 my $fail = "Could not apply patch '$patch'";
6132                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6133                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6134                 delete $self->{build_dir};
6135                 return;
6136             }
6137         }
6138         $self->{patched}++;
6139     }
6140     return 1;
6141 }
6142
6143 sub _patch_p_parameter {
6144     my($self,$fh) = @_;
6145     my $cnt_files   = 0;
6146     my $cnt_p0files = 0;
6147     local($_);
6148     while ($_ = $fh->READLINE) {
6149         if (
6150             $CPAN::Config->{applypatch}
6151             &&
6152             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6153            ) {
6154             return "applypatch"
6155         }
6156         next unless /^[\*\+]{3}\s(\S+)/;
6157         my $file = $1;
6158         $cnt_files++;
6159         $cnt_p0files++ if -f $file;
6160         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6161             if $CPAN::DEBUG;
6162     }
6163     return "-p1" unless $cnt_files;
6164     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6165 }
6166
6167 #-> sub CPAN::Distribution::_edge_cases
6168 # with "configure" or "Makefile" or single file scripts
6169 sub _edge_cases {
6170     my($self,$mpl,$packagedir,$local_file) = @_;
6171     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6172                          $mpl,
6173                          CPAN::anycwd(),
6174                         )) if $CPAN::DEBUG;
6175     my($configure) = File::Spec->catfile($packagedir,"Configure");
6176     if (-f $configure) {
6177         # do we have anything to do?
6178         $self->{configure} = $configure;
6179     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6180         $CPAN::Frontend->mywarn(qq{
6181 Package comes with a Makefile and without a Makefile.PL.
6182 We\'ll try to build it with that Makefile then.
6183 });
6184         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6185         $CPAN::Frontend->mysleep(2);
6186     } else {
6187         my $cf = $self->called_for || "unknown";
6188         if ($cf =~ m|/|) {
6189             $cf =~ s|.*/||;
6190             $cf =~ s|\W.*||;
6191         }
6192         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6193         $cf = "unknown" unless length($cf);
6194         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6195   (The test -f "$mpl" returned false.)
6196   Writing one on our own (setting NAME to $cf)\a\n});
6197         $self->{had_no_makefile_pl}++;
6198         $CPAN::Frontend->mysleep(3);
6199
6200         # Writing our own Makefile.PL
6201
6202         my $script = "";
6203         if ($self->{archived} eq "maybe_pl") {
6204             my $fh = FileHandle->new;
6205             my $script_file = File::Spec->catfile($packagedir,$local_file);
6206             $fh->open($script_file)
6207                 or Carp::croak("Could not open script '$script_file': $!");
6208             local $/ = "\n";
6209             # name parsen und prereq
6210             my($state) = "poddir";
6211             my($name, $prereq) = ("", "");
6212             while (<$fh>) {
6213                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6214                     if ($1 eq 'NAME') {
6215                         $state = "name";
6216                     } elsif ($1 eq 'PREREQUISITES') {
6217                         $state = "prereq";
6218                     }
6219                 } elsif ($state =~ m{^(name|prereq)$}) {
6220                     if (/^=/) {
6221                         $state = "poddir";
6222                     } elsif (/^\s*$/) {
6223                         # nop
6224                     } elsif ($state eq "name") {
6225                         if ($name eq "") {
6226                             ($name) = /^(\S+)/;
6227                             $state = "poddir";
6228                         }
6229                     } elsif ($state eq "prereq") {
6230                         $prereq .= $_;
6231                     }
6232                 } elsif (/^=cut\b/) {
6233                     last;
6234                 }
6235             }
6236             $fh->close;
6237
6238             for ($name) {
6239                 s{.*<}{};       # strip X<...>
6240                 s{>.*}{};
6241             }
6242             chomp $prereq;
6243             $prereq = join " ", split /\s+/, $prereq;
6244             my($PREREQ_PM) = join("\n", map {
6245                 s{.*<}{};       # strip X<...>
6246                 s{>.*}{};
6247                 if (/[\s\'\"]/) { # prose?
6248                 } else {
6249                     s/[^\w:]$//; # period?
6250                     " "x28 . "'$_' => 0,";
6251                 }
6252             } split /\s*,\s*/, $prereq);
6253
6254             $script = "
6255               EXE_FILES => ['$name'],
6256               PREREQ_PM => {
6257 $PREREQ_PM
6258                            },
6259 ";
6260             if ($name) {
6261                 my $to_file = File::Spec->catfile($packagedir, $name);
6262                 rename $script_file, $to_file
6263                     or die "Can't rename $script_file to $to_file: $!";
6264             }
6265         }
6266
6267         my $fh = FileHandle->new;
6268         $fh->open(">$mpl")
6269             or Carp::croak("Could not open >$mpl: $!");
6270         $fh->print(
6271                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6272 # because there was no Makefile.PL supplied.
6273 # Autogenerated on: }.scalar localtime().qq{
6274
6275 use ExtUtils::MakeMaker;
6276 WriteMakefile(
6277               NAME => q[$cf],$script
6278              );
6279 });
6280         $fh->close;
6281     }
6282 }
6283
6284 #-> CPAN::Distribution::_signature_business
6285 sub _signature_business {
6286     my($self) = @_;
6287     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6288                                                       q{check_sigs});
6289     if ($check_sigs) {
6290         if ($CPAN::META->has_inst("Module::Signature")) {
6291             if (-f "SIGNATURE") {
6292                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6293                 my $rv = Module::Signature::verify();
6294                 if ($rv != Module::Signature::SIGNATURE_OK() and
6295                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6296                     $CPAN::Frontend->mywarn(
6297                                             qq{\nSignature invalid for }.
6298                                             qq{distribution file. }.
6299                                             qq{Please investigate.\n\n}
6300                                            );
6301
6302                     my $wrap =
6303                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6304                                 qq{while checking its signature, so it could        }.
6305                                 qq{be invalid. Maybe you have configured            }.
6306                                 qq{your 'urllist' with a bad URL. Please check this }.
6307                                 qq{array with 'o conf urllist' and retry. Or        }.
6308                                 qq{examine the distribution in a subshell. Try
6309   look %s
6310 and run
6311   cpansign -v
6312 },
6313                                 $self->{localfile},
6314                                 $self->pretty_id,
6315                                );
6316                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6317                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6318                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6319                 } else {
6320                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6321                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6322                 }
6323             } else {
6324                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6325             }
6326         } else {
6327             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6328         }
6329     }
6330 }
6331
6332 #-> CPAN::Distribution::untar_me ;
6333 sub untar_me {
6334     my($self,$ct) = @_;
6335     $self->{archived} = "tar";
6336     if ($ct->untar()) {
6337         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6338     } else {
6339         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6340     }
6341 }
6342
6343 # CPAN::Distribution::unzip_me ;
6344 sub unzip_me {
6345     my($self,$ct) = @_;
6346     $self->{archived} = "zip";
6347     if ($ct->unzip()) {
6348         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6349     } else {
6350         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6351     }
6352     return;
6353 }
6354
6355 sub handle_singlefile {
6356     my($self,$local_file) = @_;
6357
6358     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6359         $self->{archived} = "pm";
6360     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6361         $self->{archived} = "patch";
6362     } else {
6363         $self->{archived} = "maybe_pl";
6364     }
6365
6366     my $to = File::Basename::basename($local_file);
6367     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6368         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6369             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6370         } else {
6371             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6372         }
6373     } else {
6374         if (File::Copy::cp($local_file,".")) {
6375             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6376         } else {
6377             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6378         }
6379     }
6380     return $to;
6381 }
6382
6383 #-> sub CPAN::Distribution::new ;
6384 sub new {
6385     my($class,%att) = @_;
6386
6387     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6388
6389     my $this = { %att };
6390     return bless $this, $class;
6391 }
6392
6393 #-> sub CPAN::Distribution::look ;
6394 sub look {
6395     my($self) = @_;
6396
6397     if ($^O eq 'MacOS') {
6398       $self->Mac::BuildTools::look;
6399       return;
6400     }
6401
6402     if (  $CPAN::Config->{'shell'} ) {
6403         $CPAN::Frontend->myprint(qq{
6404 Trying to open a subshell in the build directory...
6405 });
6406     } else {
6407         $CPAN::Frontend->myprint(qq{
6408 Your configuration does not define a value for subshells.
6409 Please define it with "o conf shell <your shell>"
6410 });
6411         return;
6412     }
6413     my $dist = $self->id;
6414     my $dir;
6415     unless ($dir = $self->dir) {
6416         $self->get;
6417     }
6418     unless ($dir ||= $self->dir) {
6419         $CPAN::Frontend->mywarn(qq{
6420 Could not determine which directory to use for looking at $dist.
6421 });
6422         return;
6423     }
6424     my $pwd  = CPAN::anycwd();
6425     $self->safe_chdir($dir);
6426     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6427     {
6428         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6429         $ENV{CPAN_SHELL_LEVEL} += 1;
6430         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6431         unless (system($shell) == 0) {
6432             my $code = $? >> 8;
6433             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6434         }
6435     }
6436     $self->safe_chdir($pwd);
6437 }
6438
6439 # CPAN::Distribution::cvs_import ;
6440 sub cvs_import {
6441     my($self) = @_;
6442     $self->get;
6443     my $dir = $self->dir;
6444
6445     my $package = $self->called_for;
6446     my $module = $CPAN::META->instance('CPAN::Module', $package);
6447     my $version = $module->cpan_version;
6448
6449     my $userid = $self->cpan_userid;
6450
6451     my $cvs_dir = (split /\//, $dir)[-1];
6452     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6453     my $cvs_root =
6454       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6455     my $cvs_site_perl =
6456       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6457     if ($cvs_site_perl) {
6458         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6459     }
6460     my $cvs_log = qq{"imported $package $version sources"};
6461     $version =~ s/\./_/g;
6462     # XXX cvs: undocumented and unclear how it was meant to work
6463     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6464                "$cvs_dir", $userid, "v$version");
6465
6466     my $pwd  = CPAN::anycwd();
6467     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6468
6469     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6470
6471     $CPAN::Frontend->myprint(qq{@cmd\n});
6472     system(@cmd) == 0 or
6473     # XXX cvs
6474         $CPAN::Frontend->mydie("cvs import failed");
6475     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6476 }
6477
6478 #-> sub CPAN::Distribution::readme ;
6479 sub readme {
6480     my($self) = @_;
6481     my($dist) = $self->id;
6482     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6483     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6484     my($local_file);
6485     my($local_wanted) =
6486          File::Spec->catfile(
6487                              $CPAN::Config->{keep_source_where},
6488                              "authors",
6489                              "id",
6490                              split(/\//,"$sans.readme"),
6491                             );
6492     $self->debug("Doing localize") if $CPAN::DEBUG;
6493     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6494                                       $local_wanted)
6495         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6496
6497     if ($^O eq 'MacOS') {
6498         Mac::BuildTools::launch_file($local_file);
6499         return;
6500     }
6501
6502     my $fh_pager = FileHandle->new;
6503     local($SIG{PIPE}) = "IGNORE";
6504     my $pager = $CPAN::Config->{'pager'} || "cat";
6505     $fh_pager->open("|$pager")
6506         or die "Could not open pager $pager\: $!";
6507     my $fh_readme = FileHandle->new;
6508     $fh_readme->open($local_file)
6509         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6510     $CPAN::Frontend->myprint(qq{
6511 Displaying file
6512   $local_file
6513 with pager "$pager"
6514 });
6515     $fh_pager->print(<$fh_readme>);
6516     $fh_pager->close;
6517 }
6518
6519 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6520 sub verifyCHECKSUM {
6521     my($self) = @_;
6522   EXCUSE: {
6523         my @e;
6524         $self->{CHECKSUM_STATUS} ||= "";
6525         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6526         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6527     }
6528     my($lc_want,$lc_file,@local,$basename);
6529     @local = split(/\//,$self->id);
6530     pop @local;
6531     push @local, "CHECKSUMS";
6532     $lc_want =
6533         File::Spec->catfile($CPAN::Config->{keep_source_where},
6534                             "authors", "id", @local);
6535     local($") = "/";
6536     if (my $size = -s $lc_want) {
6537         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6538         if ($self->CHECKSUM_check_file($lc_want,1)) {
6539             return $self->{CHECKSUM_STATUS} = "OK";
6540         }
6541     }
6542     $lc_file = CPAN::FTP->localize("authors/id/@local",
6543                                    $lc_want,1);
6544     unless ($lc_file) {
6545         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6546         $local[-1] .= ".gz";
6547         $lc_file = CPAN::FTP->localize("authors/id/@local",
6548                                        "$lc_want.gz",1);
6549         if ($lc_file) {
6550             $lc_file =~ s/\.gz(?!\n)\Z//;
6551             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6552         } else {
6553             return;
6554         }
6555     }
6556     if ($self->CHECKSUM_check_file($lc_file)) {
6557         return $self->{CHECKSUM_STATUS} = "OK";
6558     }
6559 }
6560
6561 #-> sub CPAN::Distribution::SIG_check_file ;
6562 sub SIG_check_file {
6563     my($self,$chk_file) = @_;
6564     my $rv = eval { Module::Signature::_verify($chk_file) };
6565
6566     if ($rv == Module::Signature::SIGNATURE_OK()) {
6567         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6568         return $self->{SIG_STATUS} = "OK";
6569     } else {
6570         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6571                                  qq{distribution file. }.
6572                                  qq{Please investigate.\n\n}.
6573                                  $self->as_string,
6574                                 $CPAN::META->instance(
6575                                                         'CPAN::Author',
6576                                                         $self->cpan_userid
6577                                                         )->as_string);
6578
6579         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6580 is invalid. Maybe you have configured your 'urllist' with
6581 a bad URL. Please check this array with 'o conf urllist', and
6582 retry.};
6583
6584         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6585     }
6586 }
6587
6588 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6589
6590 # sloppy is 1 when we have an old checksums file that maybe is good
6591 # enough
6592
6593 sub CHECKSUM_check_file {
6594     my($self,$chk_file,$sloppy) = @_;
6595     my($cksum,$file,$basename);
6596
6597     $sloppy ||= 0;
6598     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6599     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6600                                                       q{check_sigs});
6601     if ($check_sigs) {
6602         if ($CPAN::META->has_inst("Module::Signature")) {
6603             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6604             $self->SIG_check_file($chk_file);
6605         } else {
6606             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6607         }
6608     }
6609
6610     $file = $self->{localfile};
6611     $basename = File::Basename::basename($file);
6612     my $fh = FileHandle->new;
6613     if (open $fh, $chk_file){
6614         local($/);
6615         my $eval = <$fh>;
6616         $eval =~ s/\015?\012/\n/g;
6617         close $fh;
6618         my($comp) = Safe->new();
6619         $cksum = $comp->reval($eval);
6620         if ($@) {
6621             rename $chk_file, "$chk_file.bad";
6622             Carp::confess($@) if $@;
6623         }
6624     } else {
6625         Carp::carp "Could not open $chk_file for reading";
6626     }
6627
6628     if (! ref $cksum or ref $cksum ne "HASH") {
6629         $CPAN::Frontend->mywarn(qq{
6630 Warning: checksum file '$chk_file' broken.
6631
6632 When trying to read that file I expected to get a hash reference
6633 for further processing, but got garbage instead.
6634 });
6635         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6636         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6637         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6638         return;
6639     } elsif (exists $cksum->{$basename}{sha256}) {
6640         $self->debug("Found checksum for $basename:" .
6641                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6642
6643         open($fh, $file);
6644         binmode $fh;
6645         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6646         $fh->close;
6647         $fh = CPAN::Tarzip->TIEHANDLE($file);
6648
6649         unless ($eq) {
6650           my $dg = Digest::SHA->new(256);
6651           my($data,$ref);
6652           $ref = \$data;
6653           while ($fh->READ($ref, 4096) > 0){
6654             $dg->add($data);
6655           }
6656           my $hexdigest = $dg->hexdigest;
6657           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6658         }
6659
6660         if ($eq) {
6661           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6662           return $self->{CHECKSUM_STATUS} = "OK";
6663         } else {
6664             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6665                                      qq{distribution file. }.
6666                                      qq{Please investigate.\n\n}.
6667                                      $self->as_string,
6668                                      $CPAN::META->instance(
6669                                                            'CPAN::Author',
6670                                                            $self->cpan_userid
6671                                                           )->as_string);
6672
6673             my $wrap = qq{I\'d recommend removing $file. Its
6674 checksum is incorrect. Maybe you have configured your 'urllist' with
6675 a bad URL. Please check this array with 'o conf urllist', and
6676 retry.};
6677
6678             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6679
6680             # former versions just returned here but this seems a
6681             # serious threat that deserves a die
6682
6683             # $CPAN::Frontend->myprint("\n\n");
6684             # sleep 3;
6685             # return;
6686         }
6687         # close $fh if fileno($fh);
6688     } else {
6689         return if $sloppy;
6690         unless ($self->{CHECKSUM_STATUS}) {
6691             $CPAN::Frontend->mywarn(qq{
6692 Warning: No checksum for $basename in $chk_file.
6693
6694 The cause for this may be that the file is very new and the checksum
6695 has not yet been calculated, but it may also be that something is
6696 going awry right now.
6697 });
6698             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6699             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6700         }
6701         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6702         return;
6703     }
6704 }
6705
6706 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6707 sub eq_CHECKSUM {
6708     my($self,$fh,$expect) = @_;
6709     if ($CPAN::META->has_inst("Digest::SHA")) {
6710         my $dg = Digest::SHA->new(256);
6711         my($data);
6712         while (read($fh, $data, 4096)){
6713             $dg->add($data);
6714         }
6715         my $hexdigest = $dg->hexdigest;
6716         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6717         return $hexdigest eq $expect;
6718     }
6719     return 1;
6720 }
6721
6722 #-> sub CPAN::Distribution::force ;
6723
6724 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6725 # effect by autoinspection, not by inspecting a global variable. One
6726 # of the reason why this was chosen to work that way was the treatment
6727 # of dependencies. They should not automatically inherit the force
6728 # status. But this has the downside that ^C and die() will return to
6729 # the prompt but will not be able to reset the force_update
6730 # attributes. We try to correct for it currently in the read_metadata
6731 # routine, and immediately before we check for a Signal. I hope this
6732 # works out in one of v1.57_53ff
6733
6734 # "Force get forgets previous error conditions"
6735
6736 #-> sub CPAN::Distribution::fforce ;
6737 sub fforce {
6738   my($self, $method) = @_;
6739   $self->force($method,1);
6740 }
6741
6742 #-> sub CPAN::Distribution::force ;
6743 sub force {
6744   my($self, $method,$fforce) = @_;
6745   my %phase_map = (
6746                    get => [
6747                            "unwrapped",
6748                            "build_dir",
6749                            "archived",
6750                            "localfile",
6751                            "CHECKSUM_STATUS",
6752                            "signature_verify",
6753                            "prefs",
6754                            "prefs_file",
6755                            "prefs_file_doc",
6756                           ],
6757                    make => [
6758                             "writemakefile",
6759                             "make",
6760                             "modulebuild",
6761                             "prereq_pm",
6762                             "prereq_pm_detected",
6763                            ],
6764                    test => [
6765                             "badtestcnt",
6766                             "make_test",
6767                            ],
6768                    install => [
6769                                "install",
6770                               ],
6771                    unknown => [
6772                                "reqtype",
6773                                "yaml_content",
6774                               ],
6775                   );
6776   my $methodmatch = 0;
6777   my $ldebug = 0;
6778  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6779       $methodmatch = 1 if $fforce || $phase eq $method;
6780       next unless $methodmatch;
6781     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6782           if ($phase eq "get") {
6783               if (substr($self->id,-1,1) eq "."
6784                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6785                   # cannot be undone for local distros
6786                   next ATTRIBUTE;
6787               }
6788               if ($att eq "build_dir"
6789                   && $self->{build_dir}
6790                   && $CPAN::META->{is_tested}
6791                  ) {
6792                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6793               }
6794           } elsif ($phase eq "test") {
6795               if ($att eq "make_test"
6796                   && $self->{make_test}
6797                   && $self->{make_test}{COMMANDID}
6798                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6799                  ) {
6800                   # endless loop too likely
6801                   next ATTRIBUTE;
6802               }
6803           }
6804           delete $self->{$att};
6805           if ($ldebug || $CPAN::DEBUG) {
6806               # local $CPAN::DEBUG = 16; # Distribution
6807               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6808           }
6809       }
6810   }
6811   if ($method && $method =~ /make|test|install/) {
6812     $self->{force_update} = 1; # name should probably have been force_install
6813   }
6814 }
6815
6816 #-> sub CPAN::Distribution::notest ;
6817 sub notest {
6818   my($self, $method) = @_;
6819   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
6820   $self->{"notest"}++; # name should probably have been force_install
6821 }
6822
6823 #-> sub CPAN::Distribution::unnotest ;
6824 sub unnotest {
6825   my($self) = @_;
6826   # warn "XDEBUG: deleting notest";
6827   delete $self->{notest};
6828 }
6829
6830 #-> sub CPAN::Distribution::unforce ;
6831 sub unforce {
6832   my($self) = @_;
6833   delete $self->{force_update};
6834 }
6835
6836 #-> sub CPAN::Distribution::isa_perl ;
6837 sub isa_perl {
6838   my($self) = @_;
6839   my $file = File::Basename::basename($self->id);
6840   if ($file =~ m{ ^ perl
6841                   -?
6842                   (5)
6843                   ([._-])
6844                   (
6845                    \d{3}(_[0-4][0-9])?
6846                    |
6847                    \d+\.\d+
6848                   )
6849                   \.tar[._-](?:gz|bz2)
6850                   (?!\n)\Z
6851                 }xs){
6852     return "$1.$3";
6853   } elsif ($self->cpan_comment
6854            &&
6855            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6856     return $1;
6857   }
6858 }
6859
6860
6861 #-> sub CPAN::Distribution::perl ;
6862 sub perl {
6863     my ($self) = @_;
6864     if (! $self) {
6865         use Carp qw(carp);
6866         carp __PACKAGE__ . "::perl was called without parameters.";
6867     }
6868     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6869 }
6870
6871
6872 #-> sub CPAN::Distribution::make ;
6873 sub make {
6874     my($self) = @_;
6875     if (my $goto = $self->prefs->{goto}) {
6876         return $self->goto($goto);
6877     }
6878     my $make = $self->{modulebuild} ? "Build" : "make";
6879     # Emergency brake if they said install Pippi and get newest perl
6880     if ($self->isa_perl) {
6881       if (
6882           $self->called_for ne $self->id &&
6883           ! $self->{force_update}
6884          ) {
6885         # if we die here, we break bundles
6886         $CPAN::Frontend
6887             ->mywarn(sprintf(
6888                              qq{The most recent version "%s" of the module "%s"
6889 is part of the perl-%s distribution. To install that, you need to run
6890   force install %s   --or--
6891   install %s
6892 },
6893                              $CPAN::META->instance(
6894                                                    'CPAN::Module',
6895                                                    $self->called_for
6896                                                   )->cpan_version,
6897                              $self->called_for,
6898                              $self->isa_perl,
6899                              $self->called_for,
6900                              $self->id,
6901                             ));
6902         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6903         $CPAN::Frontend->mysleep(1);
6904         return;
6905       }
6906     }
6907     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6908     $self->get;
6909     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6910                            ? $ENV{PERL5LIB}
6911                            : ($ENV{PERLLIB} || "");
6912     $CPAN::META->set_perl5lib;
6913     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6914
6915     if ($CPAN::Signal){
6916       delete $self->{force_update};
6917       return;
6918     }
6919
6920     my $builddir;
6921   EXCUSE: {
6922         my @e;
6923         if (!$self->{archived} || $self->{archived} eq "NO") {
6924             push @e, "Is neither a tar nor a zip archive.";
6925         }
6926
6927         if (!$self->{unwrapped}
6928             || (
6929                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6930                 $self->{unwrapped}->failed :
6931                 $self->{unwrapped} =~ /^NO/
6932                )) {
6933             push @e, "Had problems unarchiving. Please build manually";
6934         }
6935
6936         unless ($self->{force_update}) {
6937             exists $self->{signature_verify} and
6938                 (
6939                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6940                  $self->{signature_verify}->failed :
6941                  $self->{signature_verify} =~ /^NO/
6942                 )
6943                 and push @e, "Did not pass the signature test.";
6944         }
6945
6946         if (exists $self->{writemakefile} &&
6947             (
6948              UNIVERSAL::can($self->{writemakefile},"failed") ?
6949              $self->{writemakefile}->failed :
6950              $self->{writemakefile} =~ /^NO/
6951             )) {
6952             # XXX maybe a retry would be in order?
6953             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6954                 $self->{writemakefile}->text :
6955                     $self->{writemakefile};
6956             $err =~ s/^NO\s*//;
6957             $err ||= "Had some problem writing Makefile";
6958             $err .= ", won't make";
6959             push @e, $err;
6960         }
6961
6962         if (defined $self->{make}) {
6963             if ($self->{make}->failed) {
6964                 if ($self->{force_update}) {
6965                     # Trying an already failed 'make' (unless somebody else blocks)
6966                 } else {
6967                     # introduced for turning recursion detection into a distrostatus
6968                     my $error = length $self->{make}>3
6969                         ? substr($self->{make},3) : "Unknown error";
6970                     $CPAN::Frontend->mywarn("Could not make: $error\n");
6971                     $self->store_persistent_state;
6972                     return;
6973                 }
6974             } else {
6975                 push @e, "Has already been made";
6976             }
6977         }
6978
6979         if ($self->{later}) { # see also undelay
6980             if ($self->unsat_prereq) {
6981                 push @e, $self->{later};
6982             }
6983         }
6984
6985         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6986         $builddir = $self->dir or
6987             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6988         unless (chdir $builddir) {
6989             push @e, "Couldn't chdir to '$builddir': $!";
6990         }
6991         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6992     }
6993     if ($CPAN::Signal){
6994       delete $self->{force_update};
6995       return;
6996     }
6997     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6998     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6999
7000     if ($^O eq 'MacOS') {
7001         Mac::BuildTools::make($self);
7002         return;
7003     }
7004
7005     my %env;
7006     while (my($k,$v) = each %ENV) {
7007         next unless defined $v;
7008         $env{$k} = $v;
7009     }
7010     local %ENV = %env;
7011     my $system;
7012     if (my $commandline = $self->prefs->{pl}{commandline}) {
7013         $system = $commandline;
7014         $ENV{PERL} = $^X;
7015     } elsif ($self->{'configure'}) {
7016         $system = $self->{'configure'};
7017     } elsif ($self->{modulebuild}) {
7018         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7019         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7020     } else {
7021         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7022         my $switch = "";
7023 # This needs a handler that can be turned on or off:
7024 #       $switch = "-MExtUtils::MakeMaker ".
7025 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7026 #           if $] > 5.00310;
7027         my $makepl_arg = $self->make_x_arg("pl");
7028         $system = sprintf("%s%s Makefile.PL%s",
7029                           $perl,
7030                           $switch ? " $switch" : "",
7031                           $makepl_arg ? " $makepl_arg" : "",
7032                          );
7033     }
7034     if (my $env = $self->prefs->{pl}{env}) {
7035         for my $e (keys %$env) {
7036             $ENV{$e} = $env->{$e};
7037         }
7038     }
7039     if (exists $self->{writemakefile}) {
7040     } else {
7041         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7042         my($ret,$pid);
7043         $@ = "";
7044         my $go_via_alarm;
7045         if ($CPAN::Config->{inactivity_timeout}) {
7046             require Config;
7047             if ($Config::Config{d_alarm}
7048                 &&
7049                 $Config::Config{d_alarm} eq "define"
7050                ) {
7051                 $go_via_alarm++
7052             } else {
7053                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7054                                         "variable 'inactivity_timeout' to ".
7055                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7056                                         "on this machine the system call 'alarm' ".
7057                                         "isn't available. This means that we cannot ".
7058                                         "provide the feature of intercepting long ".
7059                                         "waiting code and will turn this feature off.\n"
7060                                        );
7061                 $CPAN::Config->{inactivity_timeout} = 0;
7062             }
7063         }
7064         if ($go_via_alarm) {
7065             eval {
7066                 alarm $CPAN::Config->{inactivity_timeout};
7067                 local $SIG{CHLD}; # = sub { wait };
7068                 if (defined($pid = fork)) {
7069                     if ($pid) { #parent
7070                         # wait;
7071                         waitpid $pid, 0;
7072                     } else {    #child
7073                         # note, this exec isn't necessary if
7074                         # inactivity_timeout is 0. On the Mac I'd
7075                         # suggest, we set it always to 0.
7076                         exec $system;
7077                     }
7078                 } else {
7079                     $CPAN::Frontend->myprint("Cannot fork: $!");
7080                     return;
7081                 }
7082             };
7083             alarm 0;
7084             if ($@){
7085                 kill 9, $pid;
7086                 waitpid $pid, 0;
7087                 my $err = "$@";
7088                 $CPAN::Frontend->myprint($err);
7089                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7090                 $@ = "";
7091                 return;
7092             }
7093         } else {
7094             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7095                 $ret = $self->_run_via_expect($system,$expect_model);
7096                 if (! defined $ret
7097                     && $self->{writemakefile}
7098                     && $self->{writemakefile}->failed) {
7099                     # timeout
7100                     return;
7101                 }
7102             } else {
7103                 $ret = system($system);
7104             }
7105             if ($ret != 0) {
7106                 $self->{writemakefile} = CPAN::Distrostatus
7107                     ->new("NO '$system' returned status $ret");
7108                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7109                 $self->store_persistent_state;
7110                 return;
7111             }
7112         }
7113         if (-f "Makefile" || -f "Build") {
7114           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7115           delete $self->{make_clean}; # if cleaned before, enable next
7116         } else {
7117           $self->{writemakefile} = CPAN::Distrostatus
7118               ->new(qq{NO -- Unknown reason});
7119         }
7120     }
7121     if ($CPAN::Signal){
7122       delete $self->{force_update};
7123       return;
7124     }
7125     if (my @prereq = $self->unsat_prereq){
7126         if ($prereq[0][0] eq "perl") {
7127             my $need = "requires perl '$prereq[0][1]'";
7128             my $id = $self->pretty_id;
7129             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7130             $self->{make} = CPAN::Distrostatus->new("NO $need");
7131             $self->store_persistent_state;
7132             return;
7133         } else {
7134             my $follow = eval { $self->follow_prereqs(@prereq); };
7135             if (0) {
7136             } elsif ($follow){
7137                 # signal success to the queuerunner
7138                 return 1;
7139             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7140                 $CPAN::Frontend->mywarn($@);
7141                 return;
7142             }
7143         }
7144     }
7145     if ($CPAN::Signal){
7146       delete $self->{force_update};
7147       return;
7148     }
7149     if (my $commandline = $self->prefs->{make}{commandline}) {
7150         $system = $commandline;
7151         $ENV{PERL} = $^X;
7152     } else {
7153         if ($self->{modulebuild}) {
7154             unless (-f "Build") {
7155                 my $cwd = CPAN::anycwd();
7156                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7157                                         " in cwd[$cwd]. Danger, Will Robinson!");
7158                 $CPAN::Frontend->mysleep(5);
7159             }
7160             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7161         } else {
7162             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7163         }
7164         $system =~ s/\s+$//;
7165         my $make_arg = $self->make_x_arg("make");
7166         $system = sprintf("%s%s",
7167                           $system,
7168                           $make_arg ? " $make_arg" : "",
7169                          );
7170     }
7171     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7172                                                # ENV of PL, not the
7173                                                # outer ENV, but
7174                                                # unlikely to be a risk
7175         for my $e (keys %$env) {
7176             $ENV{$e} = $env->{$e};
7177         }
7178     }
7179     my $expect_model = $self->_prefs_with_expect("make");
7180     my $want_expect = 0;
7181     if ( $expect_model && @{$expect_model->{talk}} ) {
7182         my $can_expect = $CPAN::META->has_inst("Expect");
7183         if ($can_expect) {
7184             $want_expect = 1;
7185         } else {
7186             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7187                                     "system()\n");
7188         }
7189     }
7190     my $system_ok;
7191     if ($want_expect) {
7192         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7193     } else {
7194         $system_ok = system($system) == 0;
7195     }
7196     $self->introduce_myself;
7197     if ( $system_ok ) {
7198          $CPAN::Frontend->myprint("  $system -- OK\n");
7199          $self->{make} = CPAN::Distrostatus->new("YES");
7200     } else {
7201          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7202          $self->{make} = CPAN::Distrostatus->new("NO");
7203          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7204     }
7205     $self->store_persistent_state;
7206 }
7207
7208 # CPAN::Distribution::_run_via_expect
7209 sub _run_via_expect {
7210     my($self,$system,$expect_model) = @_;
7211     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7212     if ($CPAN::META->has_inst("Expect")) {
7213         my $expo = Expect->new;  # expo Expect object;
7214         $expo->spawn($system);
7215         $expect_model->{mode} ||= "deterministic";
7216         if ($expect_model->{mode} eq "deterministic") {
7217             return $self->_run_via_expect_deterministic($expo,$expect_model);
7218         } elsif ($expect_model->{mode} eq "anyorder") {
7219             return $self->_run_via_expect_anyorder($expo,$expect_model);
7220         } else {
7221             die "Panic: Illegal expect mode: $expect_model->{mode}";
7222         }
7223     } else {
7224         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7225         return system($system);
7226     }
7227 }
7228
7229 sub _run_via_expect_anyorder {
7230     my($self,$expo,$expect_model) = @_;
7231     my $timeout = $expect_model->{timeout} || 5;
7232     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7233     my $but = "";
7234   EXPECT: while () {
7235         my($eof,$ran_into_timeout);
7236         my @match = $expo->expect($timeout,
7237                                   [ eof => sub {
7238                                         $eof++;
7239                                     } ],
7240                                   [ timeout => sub {
7241                                         $ran_into_timeout++;
7242                                     } ],
7243                                   -re => eval"qr{.}",
7244                                  );
7245         if ($match[2]) {
7246             $but .= $match[2];
7247         }
7248         $but .= $expo->clear_accum;
7249         if ($eof) {
7250             $expo->soft_close;
7251             return $expo->exitstatus();
7252         } elsif ($ran_into_timeout) {
7253             # warn "DEBUG: they are asking a question, but[$but]";
7254             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7255                 my($next,$send) = @expectacopy[$i,$i+1];
7256                 my $regex = eval "qr{$next}";
7257                 # warn "DEBUG: will compare with regex[$regex].";
7258                 if ($but =~ /$regex/) {
7259                     # warn "DEBUG: will send send[$send]";
7260                     $expo->send($send);
7261                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7262                     next EXPECT;
7263                 }
7264             }
7265             my $why = "could not answer a question during the dialog";
7266             $CPAN::Frontend->mywarn("Failing: $why\n");
7267             $self->{writemakefile} =
7268                 CPAN::Distrostatus->new("NO $why");
7269             return;
7270         }
7271     }
7272 }
7273
7274 sub _run_via_expect_deterministic {
7275     my($self,$expo,$expect_model) = @_;
7276     my $ran_into_timeout;
7277     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7278     my $expecta = $expect_model->{talk};
7279   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7280         my($re,$send) = @$expecta[$i,$i+1];
7281         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7282         my $regex = eval "qr{$re}";
7283         $expo->expect($timeout,
7284                       [ eof => sub {
7285                             my $but = $expo->clear_accum;
7286                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7287 expected[$regex]\nbut[$but]\n\n");
7288                             last EXPECT;
7289                         } ],
7290                       [ timeout => sub {
7291                             my $but = $expo->clear_accum;
7292                             $CPAN::Frontend->mywarn("TIMEOUT
7293 expected[$regex]\nbut[$but]\n\n");
7294                             $ran_into_timeout++;
7295                         } ],
7296                       -re => $regex);
7297         if ($ran_into_timeout){
7298             # note that the caller expects 0 for success
7299             $self->{writemakefile} =
7300                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7301             return;
7302         }
7303         $expo->send($send);
7304     }
7305     $expo->soft_close;
7306     return $expo->exitstatus();
7307 }
7308
7309 #-> CPAN::Distribution::_validate_distropref
7310 sub _validate_distropref {
7311     my($self,@args) = @_;
7312     if (
7313         $CPAN::META->has_inst("CPAN::Kwalify")
7314         &&
7315         $CPAN::META->has_inst("Kwalify")
7316        ) {
7317         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7318         if ($@) {
7319             $CPAN::Frontend->mywarn($@);
7320         }
7321     } else {
7322         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7323     }
7324 }
7325
7326 #-> CPAN::Distribution::_find_prefs
7327 sub _find_prefs {
7328     my($self) = @_;
7329     my $distroid = $self->pretty_id;
7330     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7331     my $prefs_dir = $CPAN::Config->{prefs_dir};
7332     eval { File::Path::mkpath($prefs_dir); };
7333     if ($@) {
7334         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7335     }
7336     my $yaml_module = CPAN::_yaml_module;
7337     my @extensions;
7338     if ($CPAN::META->has_inst($yaml_module)) {
7339         push @extensions, "yml";
7340     } else {
7341         my @fallbacks;
7342         if ($CPAN::META->has_inst("Data::Dumper")) {
7343             push @extensions, "dd";
7344             push @fallbacks, "Data::Dumper";
7345         }
7346         if ($CPAN::META->has_inst("Storable")) {
7347             push @extensions, "st";
7348             push @fallbacks, "Storable";
7349         }
7350         if (@fallbacks) {
7351             local $" = " and ";
7352             unless ($self->{have_complained_about_missing_yaml}++) {
7353                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7354                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7355             }
7356         } else {
7357             unless ($self->{have_complained_about_missing_yaml}++) {
7358                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7359                                         "read prefs '$prefs_dir'\n");
7360             }
7361         }
7362     }
7363     if (@extensions) {
7364         my $dh = DirHandle->new($prefs_dir)
7365             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7366       DIRENT: for (sort $dh->read) {
7367             next if $_ eq "." || $_ eq "..";
7368             my $exte = join "|", @extensions;
7369             next unless /\.($exte)$/;
7370             my $thisexte = $1;
7371             my $abs = File::Spec->catfile($prefs_dir, $_);
7372             if (-f $abs) {
7373                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7374                 my @distropref;
7375                 if ($thisexte eq "yml") {
7376                     # need no eval because if we have no YAML we do not try to read *.yml
7377                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7378                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7379                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7380                 } elsif ($thisexte eq "dd") {
7381                     package CPAN::Eval;
7382                     no strict;
7383                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7384                     local $/;
7385                     my $eval = <FH>;
7386                     close FH;
7387                     eval $eval;
7388                     if ($@) {
7389                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7390                     }
7391                     my $i = 1;
7392                     while (${"VAR".$i}) {
7393                         push @distropref, ${"VAR".$i};
7394                         $i++;
7395                     }
7396                 } elsif ($thisexte eq "st") {
7397                     # eval because Storable is never forward compatible
7398                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7399                     if ($@) {
7400                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7401                                                 "$_, skipping\: $@");
7402                         $CPAN::Frontend->mysleep(4);
7403                         next DIRENT;
7404                     }
7405                 }
7406                 # $DB::single=1;
7407                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7408               ELEMENT: for my $y (0..$#distropref) {
7409                     my $distropref = $distropref[$y];
7410                     $self->_validate_distropref($distropref,$abs,$y);
7411                     my $match = $distropref->{match};
7412                     unless ($match) {
7413                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7414                         next ELEMENT;
7415                     }
7416                     my $ok = 1;
7417                     # do not take the order of C<keys %$match> because
7418                     # "module" is by far the slowest
7419                     my $saw_valid_subkeys = 0;
7420                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7421                         next unless exists $match->{$sub_attribute};
7422                         $saw_valid_subkeys++;
7423                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7424                         if ($sub_attribute eq "module") {
7425                             my $okm = 0;
7426                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7427                             my @modules = $self->containsmods;
7428                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7429                           MODULE: for my $module (@modules) {
7430                                 $okm ||= $module =~ /$qr/;
7431                                 last MODULE if $okm;
7432                             }
7433                             $ok &&= $okm;
7434                         } elsif ($sub_attribute eq "distribution") {
7435                             my $okd = $distroid =~ /$qr/;
7436                             $ok &&= $okd;
7437                         } elsif ($sub_attribute eq "perl") {
7438                             my $okp = $^X =~ /$qr/;
7439                             $ok &&= $okp;
7440                         } elsif ($sub_attribute eq "perlconfig") {
7441                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7442                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7443                                 # XXX should probably warn if Config does not exist
7444                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7445                                 $ok &&= $okpc;
7446                                 last if $ok == 0;
7447                             }
7448                         } else {
7449                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7450                                                    "unknown sub_attribut '$sub_attribute'. ".
7451                                                    "Please ".
7452                                                    "remove, cannot continue.");
7453                         }
7454                         last if $ok == 0; # short circuit
7455                     }
7456                     unless ($saw_valid_subkeys) {
7457                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7458                                                "missing match/* subattribute. ".
7459                                                "Please ".
7460                                                "remove, cannot continue.");
7461                     }
7462                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7463                     if ($ok) {
7464                         return {
7465                                 prefs => $distropref,
7466                                 prefs_file => $abs,
7467                                 prefs_file_doc => $y,
7468                                };
7469                     }
7470
7471                 }
7472             }
7473         }
7474         $dh->close;
7475     }
7476     return;
7477 }
7478
7479 # CPAN::Distribution::prefs
7480 sub prefs {
7481     my($self) = @_;
7482     if (exists $self->{negative_prefs_cache}
7483         &&
7484         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7485        ) {
7486         delete $self->{negative_prefs_cache};
7487         delete $self->{prefs};
7488     }
7489     if (exists $self->{prefs}) {
7490         return $self->{prefs}; # XXX comment out during debugging
7491     }
7492     if ($CPAN::Config->{prefs_dir}) {
7493         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7494         my $prefs = $self->_find_prefs();
7495         $prefs ||= ""; # avoid warning next line
7496         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7497         if ($prefs) {
7498             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7499                 $self->{$x} = $prefs->{$x};
7500             }
7501             my $bs = sprintf(
7502                              "%s[%s]",
7503                              File::Basename::basename($self->{prefs_file}),
7504                              $self->{prefs_file_doc},
7505                             );
7506             my $filler1 = "_" x 22;
7507             my $filler2 = int(66 - length($bs))/2;
7508             $filler2 = 0 if $filler2 < 0;
7509             $filler2 = " " x $filler2;
7510             $CPAN::Frontend->myprint("
7511 $filler1 D i s t r o P r e f s $filler1
7512 $filler2 $bs $filler2
7513 ");
7514             $CPAN::Frontend->mysleep(1);
7515             return $self->{prefs};
7516         }
7517     }
7518     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7519     return $self->{prefs} = +{};
7520 }
7521
7522 # CPAN::Distribution::make_x_arg
7523 sub make_x_arg {
7524     my($self, $whixh) = @_;
7525     my $make_x_arg;
7526     my $prefs = $self->prefs;
7527     if (
7528         $prefs
7529         && exists $prefs->{$whixh}
7530         && exists $prefs->{$whixh}{args}
7531         && $prefs->{$whixh}{args}
7532        ) {
7533         $make_x_arg = join(" ",
7534                            map {CPAN::HandleConfig
7535                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7536                           );
7537     }
7538     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7539     $make_x_arg ||= $CPAN::Config->{$what};
7540     return $make_x_arg;
7541 }
7542
7543 # CPAN::Distribution::_make_command
7544 sub _make_command {
7545     my ($self) = @_;
7546     if ($self) {
7547         return
7548             CPAN::HandleConfig
7549                 ->safe_quote(
7550                              CPAN::HandleConfig->prefs_lookup($self,
7551                                                               q{make})
7552                              || $Config::Config{make}
7553                              || 'make'
7554                             );
7555     } else {
7556         # Old style call, without object. Deprecated
7557         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7558         return
7559           safe_quote(undef,
7560                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7561                      || $CPAN::Config->{make}
7562                      || $Config::Config{make}
7563                      || 'make');
7564     }
7565 }
7566
7567 #-> sub CPAN::Distribution::follow_prereqs ;
7568 sub follow_prereqs {
7569     my($self) = shift;
7570     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7571     return unless @prereq_tuples;
7572     my @prereq = map { $_->[0] } @prereq_tuples;
7573     my $pretty_id = $self->pretty_id;
7574     my %map = (
7575                b => "build_requires",
7576                r => "requires",
7577                c => "commandline",
7578               );
7579     my($filler1,$filler2,$filler3,$filler4);
7580     # $DB::single=1;
7581     my $unsat = "Unsatisfied dependencies detected during";
7582     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7583     {
7584         my $r = int(($w - length($unsat))/2);
7585         my $l = $w - length($unsat) - $r;
7586         $filler1 = "-"x4 . " "x$l;
7587         $filler2 = " "x$r . "-"x4 . "\n";
7588     }
7589     {
7590         my $r = int(($w - length($pretty_id))/2);
7591         my $l = $w - length($pretty_id) - $r;
7592         $filler3 = "-"x4 . " "x$l;
7593         $filler4 = " "x$r . "-"x4 . "\n";
7594     }
7595     $CPAN::Frontend->
7596         myprint("$filler1 $unsat $filler2".
7597                 "$filler3 $pretty_id $filler4".
7598                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7599                );
7600     my $follow = 0;
7601     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7602         $follow = 1;
7603     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7604         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7605 "Shall I follow them and prepend them to the queue
7606 of modules we are processing right now?", "yes");
7607         $follow = $answer =~ /^\s*y/i;
7608     } else {
7609         local($") = ", ";
7610         $CPAN::Frontend->
7611             myprint("  Ignoring dependencies on modules @prereq\n");
7612     }
7613     if ($follow) {
7614         my $id = $self->id;
7615         # color them as dirty
7616         for my $p (@prereq) {
7617             # warn "calling color_cmd_tmps(0,1)";
7618             my $any = CPAN::Shell->expandany($p);
7619             if ($any) {
7620                 $any->color_cmd_tmps(0,2);
7621             } else {
7622                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7623                 $CPAN::Frontend->mysleep(2);
7624             }
7625         }
7626         # queue them and re-queue yourself
7627         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7628                                reverse @prereq_tuples);
7629         $self->{later} = "Delayed until after prerequisites";
7630         return 1; # signal success to the queuerunner
7631     }
7632 }
7633
7634 #-> sub CPAN::Distribution::unsat_prereq ;
7635 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7636 # return ([perl=>5.008]) if we need a newer perl than we are running under
7637 sub unsat_prereq {
7638     my($self) = @_;
7639     my $prereq_pm = $self->prereq_pm or return;
7640     my(@need);
7641     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7642     my @merged = %merged;
7643     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7644   NEED: while (my($need_module, $need_version) = each %merged) {
7645         my($available_version,$available_file,$nmo);
7646         if ($need_module eq "perl") {
7647             $available_version = $];
7648             $available_file = $^X;
7649         } else {
7650             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7651             next if $nmo->uptodate;
7652             $available_file = $nmo->available_file;
7653
7654             # if they have not specified a version, we accept any installed one
7655             if (defined $available_file
7656                 and ( # a few quick shortcurcuits
7657                      not defined $need_version
7658                      or $need_version eq '0'    # "==" would trigger warning when not numeric
7659                      or $need_version eq "undef"
7660                     )) {
7661                 next NEED;
7662             }
7663
7664             $available_version = $nmo->available_version;
7665         }
7666
7667         # We only want to install prereqs if either they're not installed
7668         # or if the installed version is too old. We cannot omit this
7669         # check, because if 'force' is in effect, nobody else will check.
7670         if (defined $available_file) {
7671             my(@all_requirements) = split /\s*,\s*/, $need_version;
7672             local($^W) = 0;
7673             my $ok = 0;
7674           RQ: for my $rq (@all_requirements) {
7675                 if ($rq =~ s|>=\s*||) {
7676                 } elsif ($rq =~ s|>\s*||) {
7677                     # 2005-12: one user
7678                     if (CPAN::Version->vgt($available_version,$rq)){
7679                         $ok++;
7680                     }
7681                     next RQ;
7682                 } elsif ($rq =~ s|!=\s*||) {
7683                     # 2005-12: no user
7684                     if (CPAN::Version->vcmp($available_version,$rq)){
7685                         $ok++;
7686                         next RQ;
7687                     } else {
7688                         last RQ;
7689                     }
7690                 } elsif ($rq =~ m|<=?\s*|) {
7691                     # 2005-12: no user
7692                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7693                     $ok++;
7694                     next RQ;
7695                 }
7696                 if (! CPAN::Version->vgt($rq, $available_version)){
7697                     $ok++;
7698                 }
7699                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7700                                     "available_version[%s]rq[%s]ok[%d]",
7701                                     $need_module,
7702                                     $available_file,
7703                                     $available_version,
7704                                     CPAN::Version->readable($rq),
7705                                     $ok,
7706                                    )) if $CPAN::DEBUG;
7707             }
7708             next NEED if $ok == @all_requirements;
7709         }
7710
7711         if ($need_module eq "perl") {
7712             return ["perl", $need_version];
7713         }
7714         if ($self->{sponsored_mods}{$need_module}++){
7715             # We have already sponsored it and for some reason it's still
7716             # not available. So we do ... what??
7717
7718             # if we push it again, we have a potential infinite loop
7719
7720             # The following "next" was a very problematic construct.
7721             # It helped a lot but broke some day and had to be
7722             # replaced.
7723
7724             # We must be able to deal with modules that come again and
7725             # again as a prereq and have themselves prereqs and the
7726             # queue becomes long but finally we would find the correct
7727             # order. The RecursiveDependency check should trigger a
7728             # die when it's becoming too weird. Unfortunately removing
7729             # this next breaks many other things.
7730
7731             # The bug that brought this up is described in Todo under
7732             # "5.8.9 cannot install Compress::Zlib"
7733
7734             # next; # this is the next that had to go away
7735
7736             # The following "next NEED" are fine and the error message
7737             # explains well what is going on. For example when the DBI
7738             # fails and consequently DBD::SQLite fails and now we are
7739             # processing CPAN::SQLite. Then we must have a "next" for
7740             # DBD::SQLite. How can we get it and how can we identify
7741             # all other cases we must identify?
7742
7743             my $do = $nmo->distribution;
7744             next NEED unless $do; # not on CPAN
7745           NOSAYER: for my $nosayer (
7746                                     "unwrapped",
7747                                     "writemakefile",
7748                                     "signature_verify",
7749                                     "make",
7750                                     "make_test",
7751                                     "install",
7752                                     "make_clean",
7753                                    ) {
7754                 if ($do->{$nosayer}) {
7755                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
7756                         $do->{$nosayer}->failed :
7757                         $do->{$nosayer} =~ /^NO/) {
7758                         if ($nosayer eq "make_test"
7759                             &&
7760                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7761                            ) {
7762                             next NOSAYER;
7763                         }
7764                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7765                                                 "'$need_module => $need_version' ".
7766                                                 "for '$self->{ID}' failed when ".
7767                                                 "processing '$do->{ID}' with ".
7768                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
7769                                                 "but chances to succeed are limited.\n"
7770                                                );
7771                         next NEED;
7772                     } else { # the other guy succeeded
7773                         if ($nosayer eq "install") {
7774                             # we had this with
7775                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
7776                             # 2007-03
7777                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7778                                                     "'$need_module => $need_version' ".
7779                                                     "for '$self->{ID}' already installed ".
7780                                                     "but installation looks suspicious. ".
7781                                                     "Skipping another installation attempt, ".
7782                                                     "to prevent looping endlessly.\n"
7783                                                    );
7784                             next NEED;
7785                         }
7786                     }
7787                 }
7788             }
7789         }
7790         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7791         push @need, [$need_module,$needed_as];
7792     }
7793     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7794     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7795     @need;
7796 }
7797
7798 #-> sub CPAN::Distribution::read_yaml ;
7799 sub read_yaml {
7800     my($self) = @_;
7801     return $self->{yaml_content} if exists $self->{yaml_content};
7802     my $build_dir = $self->{build_dir};
7803     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7804     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7805     return unless -f $yaml;
7806     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7807     if ($@) {
7808         $CPAN::Frontend->mywarn("Could not read ".
7809                                 "'$yaml'. Falling back to other ".
7810                                 "methods to determine prerequisites\n");
7811         return $self->{yaml_content} = undef; # if we die, then we
7812                                               # cannot read YAML's own
7813                                               # META.yml
7814     }
7815     # not "authoritative"
7816     if (not exists $self->{yaml_content}{dynamic_config}
7817         or $self->{yaml_content}{dynamic_config}
7818        ) {
7819         $self->{yaml_content} = undef;
7820     }
7821     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7822         if $CPAN::DEBUG;
7823     return $self->{yaml_content};
7824 }
7825
7826 #-> sub CPAN::Distribution::prereq_pm ;
7827 sub prereq_pm {
7828     my($self) = @_;
7829     $self->{prereq_pm_detected} ||= 0;
7830     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7831     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7832     return unless $self->{writemakefile}  # no need to have succeeded
7833                                           # but we must have run it
7834         || $self->{modulebuild};
7835     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7836                 $self->{writemakefile}||"",
7837                 $self->{modulebuild}||"",
7838                ) if $CPAN::DEBUG;
7839     my($req,$breq);
7840     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7841         $req =  $yaml->{requires} || {};
7842         $breq =  $yaml->{build_requires} || {};
7843         undef $req unless ref $req eq "HASH" && %$req;
7844         if ($req) {
7845             if ($yaml->{generated_by} &&
7846                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7847                 my $eummv = do { local $^W = 0; $1+0; };
7848                 if ($eummv < 6.2501) {
7849                     # thanks to Slaven for digging that out: MM before
7850                     # that could be wrong because it could reflect a
7851                     # previous release
7852                     undef $req;
7853                 }
7854             }
7855             my $areq;
7856             my $do_replace;
7857             while (my($k,$v) = each %{$req||{}}) {
7858                 if ($v =~ /\d/) {
7859                     $areq->{$k} = $v;
7860                 } elsif ($k =~ /[A-Za-z]/ &&
7861                          $v =~ /[A-Za-z]/ &&
7862                          $CPAN::META->exists("Module",$v)
7863                         ) {
7864                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7865                                             "requires hash: $k => $v; I'll take both ".
7866                                             "key and value as a module name\n");
7867                     $CPAN::Frontend->mysleep(1);
7868                     $areq->{$k} = 0;
7869                     $areq->{$v} = 0;
7870                     $do_replace++;
7871                 }
7872             }
7873             $req = $areq if $do_replace;
7874         }
7875     }
7876     unless ($req || $breq) {
7877         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7878         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7879         my $fh;
7880         if (-f $makefile
7881             and
7882             $fh = FileHandle->new("<$makefile\0")) {
7883             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7884             local($/) = "\n";
7885             while (<$fh>) {
7886                 last if /MakeMaker post_initialize section/;
7887                 my($p) = m{^[\#]
7888                            \s+PREREQ_PM\s+=>\s+(.+)
7889                        }x;
7890                 next unless $p;
7891                 # warn "Found prereq expr[$p]";
7892
7893                 #  Regexp modified by A.Speer to remember actual version of file
7894                 #  PREREQ_PM hash key wants, then add to
7895                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7896                     # In case a prereq is mentioned twice, complain.
7897                     if ( defined $req->{$1} ) {
7898                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7899                             "last mention wins";
7900                     }
7901                     my($m,$n) = ($1,$2);
7902                     if ($n =~ /^q\[(.*?)\]$/) {
7903                         $n = $1;
7904                     }
7905                     $req->{$m} = $n;
7906                 }
7907                 last;
7908             }
7909         }
7910     }
7911     unless ($req || $breq) {
7912         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7913         my $buildfile = File::Spec->catfile($build_dir,"Build");
7914         if (-f $buildfile) {
7915             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7916             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7917             if (-f $build_prereqs) {
7918                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7919                 my $content = do { local *FH;
7920                                    open FH, $build_prereqs
7921                                        or $CPAN::Frontend->mydie("Could not open ".
7922                                                                  "'$build_prereqs': $!");
7923                                    local $/;
7924                                    <FH>;
7925                                };
7926                 my $bphash = eval $content;
7927                 if ($@) {
7928                 } else {
7929                     $req  = $bphash->{requires} || +{};
7930                     $breq = $bphash->{build_requires} || +{};
7931                 }
7932             }
7933         }
7934     }
7935     if (-f "Build.PL"
7936         && ! -f "Makefile.PL"
7937         && ! exists $req->{"Module::Build"}
7938         && ! $CPAN::META->has_inst("Module::Build")) {
7939         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7940                                 "undeclared prerequisite.\n".
7941                                 "  Adding it now as such.\n"
7942                                );
7943         $CPAN::Frontend->mysleep(5);
7944         $req->{"Module::Build"} = 0;
7945         delete $self->{writemakefile};
7946     }
7947     if ($req || $breq) {
7948         $self->{prereq_pm_detected}++;
7949         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7950     }
7951 }
7952
7953 #-> sub CPAN::Distribution::test ;
7954 sub test {
7955     my($self) = @_;
7956     if (my $goto = $self->prefs->{goto}) {
7957         return $self->goto($goto);
7958     }
7959     $self->make;
7960     if ($CPAN::Signal){
7961       delete $self->{force_update};
7962       return;
7963     }
7964     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7965     if ($self->{notest}) {
7966         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7967         return 1;
7968     }
7969
7970     my $make = $self->{modulebuild} ? "Build" : "make";
7971
7972     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7973                            ? $ENV{PERL5LIB}
7974                            : ($ENV{PERLLIB} || "");
7975
7976     $CPAN::META->set_perl5lib;
7977     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7978
7979     $CPAN::Frontend->myprint("Running $make test\n");
7980
7981 #    if (my @prereq = $self->unsat_prereq){
7982 #        if ( $CPAN::DEBUG ) {
7983 #            require Data::Dumper;
7984 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7985 #        }
7986 #        unless ($prereq[0][0] eq "perl") {
7987 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7988 #        }
7989 #    }
7990
7991   EXCUSE: {
7992         my @e;
7993         if ($self->{make} or $self->{later}) {
7994             # go ahead
7995         } else {
7996             push @e,
7997                 "Make had some problems, won't test";
7998         }
7999
8000         exists $self->{make} and
8001             (
8002              UNIVERSAL::can($self->{make},"failed") ?
8003              $self->{make}->failed :
8004              $self->{make} =~ /^NO/
8005             ) and push @e, "Can't test without successful make";
8006         $self->{badtestcnt} ||= 0;
8007         if ($self->{badtestcnt} > 0) {
8008             require Data::Dumper;
8009             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8010             push @e, "Won't repeat unsuccessful test during this command";
8011         }
8012
8013         push @e, $self->{later} if $self->{later};
8014
8015         if (exists $self->{build_dir}) {
8016             if (exists $self->{make_test}) {
8017                 if (
8018                     UNIVERSAL::can($self->{make_test},"failed") ?
8019                     $self->{make_test}->failed :
8020                     $self->{make_test} =~ /^NO/
8021                    ) {
8022                     if (
8023                         UNIVERSAL::can($self->{make_test},"commandid")
8024                         &&
8025                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8026                        ) {
8027                         push @e, "Has already been tested within this command";
8028                     }
8029                 } else {
8030                     push @e, "Has already been tested successfully";
8031                 }
8032             }
8033         } elsif (!@e) {
8034             push @e, "Has no own directory";
8035         }
8036         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8037         unless (chdir $self->{build_dir}) {
8038             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8039         }
8040         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8041     }
8042     $self->debug("Changed directory to $self->{build_dir}")
8043         if $CPAN::DEBUG;
8044
8045     if ($^O eq 'MacOS') {
8046         Mac::BuildTools::make_test($self);
8047         return;
8048     }
8049
8050     if ($self->{modulebuild}) {
8051         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8052         if (CPAN::Version->vlt($v,2.62)) {
8053             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8054   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8055             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8056             return;
8057         }
8058     }
8059
8060     my $system;
8061     if (my $commandline = $self->prefs->{test}{commandline}) {
8062         $system = $commandline;
8063         $ENV{PERL} = $^X;
8064     } elsif ($self->{modulebuild}) {
8065         $system = sprintf "%s test", $self->_build_command();
8066     } else {
8067         $system = join " ", $self->_make_command(), "test";
8068     }
8069     my $make_test_arg = $self->make_x_arg("test");
8070     $system = sprintf("%s%s",
8071                       $system,
8072                       $make_test_arg ? " $make_test_arg" : "",
8073                      );
8074     my($tests_ok);
8075     my %env;
8076     while (my($k,$v) = each %ENV) {
8077         next unless defined $v;
8078         $env{$k} = $v;
8079     }
8080     local %ENV = %env;
8081     if (my $env = $self->prefs->{test}{env}) {
8082         for my $e (keys %$env) {
8083             $ENV{$e} = $env->{$e};
8084         }
8085     }
8086     my $expect_model = $self->_prefs_with_expect("test");
8087     my $want_expect = 0;
8088     if ( $expect_model && @{$expect_model->{talk}} ) {
8089         my $can_expect = $CPAN::META->has_inst("Expect");
8090         if ($can_expect) {
8091             $want_expect = 1;
8092         } else {
8093             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8094                                     "testing without\n");
8095         }
8096     }
8097     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8098                                                        q{test_report});
8099     my $want_report;
8100     if ($test_report) {
8101         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8102         if ($can_report) {
8103             $want_report = 1;
8104         } else {
8105             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8106                                     "testing without\n");
8107         }
8108     }
8109     my $ready_to_report = $want_report;
8110     if ($ready_to_report
8111         && $self->is_dot_dist
8112        ) {
8113         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8114                                 "for local directories\n");
8115         $ready_to_report = 0;
8116     }
8117     if ($ready_to_report
8118         &&
8119         $self->prefs->{patches}
8120         &&
8121         @{$self->prefs->{patches}}
8122         &&
8123         $self->{patched}
8124        ) {
8125         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8126                                 "when the source has been patched\n");
8127         $ready_to_report = 0;
8128     }
8129     if ($want_expect) {
8130         if ($ready_to_report) {
8131             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8132                                     "not supported when distroprefs specify ".
8133                                     "an interactive test\n");
8134         }
8135         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8136     } elsif ( $ready_to_report ) {
8137         $tests_ok = CPAN::Reporter::test($self, $system);
8138     } else {
8139         $tests_ok = system($system) == 0;
8140     }
8141     $self->introduce_myself;
8142     if ( $tests_ok ) {
8143         {
8144             my @prereq;
8145
8146             # local $CPAN::DEBUG = 16; # Distribution
8147             for my $m (keys %{$self->{sponsored_mods}}) {
8148                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8149                 # XXX we need available_version which reflects
8150                 # $ENV{PERL5LIB} so that already tested but not yet
8151                 # installed modules are counted.
8152                 my $available_version = $m_obj->available_version;
8153                 my $available_file = $m_obj->available_file;
8154                 if ($available_version &&
8155                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8156                    ) {
8157                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8158                         if $CPAN::DEBUG;
8159                 } elsif ($available_file
8160                          && (
8161                              !$self->{prereq_pm}{$m}
8162                              ||
8163                              $self->{prereq_pm}{$m} == 0
8164                             )
8165                         ) {
8166                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8167                     CPAN->debug("m[$m] have available_file[$available_file]")
8168                         if $CPAN::DEBUG;
8169                 } else {
8170                     push @prereq, $m;
8171                 }
8172             }
8173             if (@prereq){
8174                 my $cnt = @prereq;
8175                 my $which = join ",", @prereq;
8176                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8177                     "$cnt dependencies missing ($which)";
8178                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8179                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8180                 $self->store_persistent_state;
8181                 return;
8182             }
8183         }
8184
8185         $CPAN::Frontend->myprint("  $system -- OK\n");
8186         $self->{make_test} = CPAN::Distrostatus->new("YES");
8187         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8188         # probably impossible to need the next line because badtestcnt
8189         # has a lifespan of one command
8190         delete $self->{badtestcnt};
8191     } else {
8192         $self->{make_test} = CPAN::Distrostatus->new("NO");
8193         $self->{badtestcnt}++;
8194         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8195     }
8196     $self->store_persistent_state;
8197 }
8198
8199 sub _prefs_with_expect {
8200     my($self,$where) = @_;
8201     return unless my $prefs = $self->prefs;
8202     return unless my $where_prefs = $prefs->{$where};
8203     if ($where_prefs->{expect}) {
8204         return {
8205                 mode => "deterministic",
8206                 timeout => 15,
8207                 talk => $where_prefs->{expect},
8208                };
8209     } elsif ($where_prefs->{"eexpect"}) {
8210         return $where_prefs->{"eexpect"};
8211     }
8212     return;
8213 }
8214
8215 #-> sub CPAN::Distribution::clean ;
8216 sub clean {
8217     my($self) = @_;
8218     my $make = $self->{modulebuild} ? "Build" : "make";
8219     $CPAN::Frontend->myprint("Running $make clean\n");
8220     unless (exists $self->{archived}) {
8221         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8222                                 "/untarred, nothing done\n");
8223         return 1;
8224     }
8225     unless (exists $self->{build_dir}) {
8226         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8227         return 1;
8228     }
8229     if (exists $self->{writemakefile}
8230         and $self->{writemakefile}->failed
8231        ) {
8232         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8233         return 1;
8234     }
8235   EXCUSE: {
8236         my @e;
8237         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8238             push @e, "make clean already called once";
8239         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8240     }
8241     chdir $self->{build_dir} or
8242         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8243     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8244
8245     if ($^O eq 'MacOS') {
8246         Mac::BuildTools::make_clean($self);
8247         return;
8248     }
8249
8250     my $system;
8251     if ($self->{modulebuild}) {
8252         unless (-f "Build") {
8253             my $cwd = CPAN::anycwd();
8254             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8255                                     " in cwd[$cwd]. Danger, Will Robinson!");
8256             $CPAN::Frontend->mysleep(5);
8257         }
8258         $system = sprintf "%s clean", $self->_build_command();
8259     } else {
8260         $system  = join " ", $self->_make_command(), "clean";
8261     }
8262     my $system_ok = system($system) == 0;
8263     $self->introduce_myself;
8264     if ( $system_ok ) {
8265       $CPAN::Frontend->myprint("  $system -- OK\n");
8266
8267       # $self->force;
8268
8269       # Jost Krieger pointed out that this "force" was wrong because
8270       # it has the effect that the next "install" on this distribution
8271       # will untar everything again. Instead we should bring the
8272       # object's state back to where it is after untarring.
8273
8274       for my $k (qw(
8275                     force_update
8276                     install
8277                     writemakefile
8278                     make
8279                     make_test
8280                    )) {
8281           delete $self->{$k};
8282       }
8283       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8284
8285     } else {
8286       # Hmmm, what to do if make clean failed?
8287
8288       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8289       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8290
8291       # 2006-02-27: seems silly to me to force a make now
8292       # $self->force("make"); # so that this directory won't be used again
8293
8294     }
8295     $self->store_persistent_state;
8296 }
8297
8298 #-> sub CPAN::Distribution::goto ;
8299 sub goto {
8300     my($self,$goto) = @_;
8301     $goto = $self->normalize($goto);
8302
8303     # inject into the queue
8304
8305     CPAN::Queue->delete($self->id);
8306     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8307
8308     # and run where we left off
8309
8310     my($method) = (caller(1))[3];
8311     CPAN->instance("CPAN::Distribution",$goto)->$method;
8312     CPAN::Queue->delete_first($goto);
8313 }
8314
8315 #-> sub CPAN::Distribution::install ;
8316 sub install {
8317     my($self) = @_;
8318     if (my $goto = $self->prefs->{goto}) {
8319         return $self->goto($goto);
8320     }
8321     # $DB::single=1;
8322     unless ($self->{badtestcnt}) {
8323         $self->test;
8324     }
8325     if ($CPAN::Signal){
8326       delete $self->{force_update};
8327       return;
8328     }
8329     my $make = $self->{modulebuild} ? "Build" : "make";
8330     $CPAN::Frontend->myprint("Running $make install\n");
8331   EXCUSE: {
8332         my @e;
8333         if ($self->{make} or $self->{later}) {
8334             # go ahead
8335         } else {
8336             push @e,
8337                 "Make had some problems, won't install";
8338         }
8339
8340         exists $self->{make} and
8341             (
8342              UNIVERSAL::can($self->{make},"failed") ?
8343              $self->{make}->failed :
8344              $self->{make} =~ /^NO/
8345             ) and
8346                 push @e, "Make had returned bad status, install seems impossible";
8347
8348         if (exists $self->{build_dir}) {
8349         } elsif (!@e) {
8350             push @e, "Has no own directory";
8351         }
8352
8353         if (exists $self->{make_test} and
8354             (
8355              UNIVERSAL::can($self->{make_test},"failed") ?
8356              $self->{make_test}->failed :
8357              $self->{make_test} =~ /^NO/
8358             )){
8359             if ($self->{force_update}) {
8360                 $self->{make_test}->text("FAILED but failure ignored because ".
8361                                          "'force' in effect");
8362             } else {
8363                 push @e, "make test had returned bad status, ".
8364                     "won't install without force"
8365             }
8366         }
8367         if (exists $self->{install}) {
8368             if (UNIVERSAL::can($self->{install},"text") ?
8369                 $self->{install}->text eq "YES" :
8370                 $self->{install} =~ /^YES/
8371                ) {
8372                 $CPAN::Frontend->myprint("  Already done\n");
8373                 $CPAN::META->is_installed($self->{build_dir});
8374                 return 1;
8375             } else {
8376                 # comment in Todo on 2006-02-11; maybe retry?
8377                 push @e, "Already tried without success";
8378             }
8379         }
8380
8381         push @e, $self->{later} if $self->{later};
8382
8383         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8384         unless (chdir $self->{build_dir}) {
8385             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8386         }
8387         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8388     }
8389     $self->debug("Changed directory to $self->{build_dir}")
8390         if $CPAN::DEBUG;
8391
8392     if ($^O eq 'MacOS') {
8393         Mac::BuildTools::make_install($self);
8394         return;
8395     }
8396
8397     my $system;
8398     if (my $commandline = $self->prefs->{install}{commandline}) {
8399         $system = $commandline;
8400         $ENV{PERL} = $^X;
8401     } elsif ($self->{modulebuild}) {
8402         my($mbuild_install_build_command) =
8403             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8404                 $CPAN::Config->{mbuild_install_build_command} ?
8405                     $CPAN::Config->{mbuild_install_build_command} :
8406                         $self->_build_command();
8407         $system = sprintf("%s install %s",
8408                           $mbuild_install_build_command,
8409                           $CPAN::Config->{mbuild_install_arg},
8410                          );
8411     } else {
8412         my($make_install_make_command) =
8413             CPAN::HandleConfig->prefs_lookup($self,
8414                                              q{make_install_make_command})
8415                   || $self->_make_command();
8416         $system = sprintf("%s install %s",
8417                           $make_install_make_command,
8418                           $CPAN::Config->{make_install_arg},
8419                          );
8420     }
8421
8422     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8423     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8424                                                 q{build_requires_install_policy});
8425     $brip ||="ask/yes";
8426     my $id = $self->id;
8427     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8428     my $want_install = "yes";
8429     if ($reqtype eq "b") {
8430         if ($brip eq "no") {
8431             $want_install = "no";
8432         } elsif ($brip =~ m|^ask/(.+)|) {
8433             my $default = $1;
8434             $default = "yes" unless $default =~ /^(y|n)/i;
8435             $want_install =
8436                 CPAN::Shell::colorable_makemaker_prompt
8437                       ("$id is just needed temporarily during building or testing. ".
8438                        "Do you want to install it permanently? (Y/n)",
8439                        $default);
8440         }
8441     }
8442     unless ($want_install =~ /^y/i) {
8443         my $is_only = "is only 'build_requires'";
8444         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8445         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8446         delete $self->{force_update};
8447         return;
8448     }
8449     my($pipe) = FileHandle->new("$system $stderr |");
8450     my($makeout) = "";
8451     while (<$pipe>){
8452         print $_; # intentionally NOT use Frontend->myprint because it
8453                   # looks irritating when we markup in color what we
8454                   # just pass through from an external program
8455         $makeout .= $_;
8456     }
8457     $pipe->close;
8458     my $close_ok = $? == 0;
8459     $self->introduce_myself;
8460     if ( $close_ok ) {
8461         $CPAN::Frontend->myprint("  $system -- OK\n");
8462         $CPAN::META->is_installed($self->{build_dir});
8463         $self->{install} = CPAN::Distrostatus->new("YES");
8464     } else {
8465         $self->{install} = CPAN::Distrostatus->new("NO");
8466         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8467         my $mimc =
8468             CPAN::HandleConfig->prefs_lookup($self,
8469                                              q{make_install_make_command});
8470         if (
8471             $makeout =~ /permission/s
8472             && $> > 0
8473             && (
8474                 ! $mimc
8475                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8476                                                               q{make}))
8477                )
8478            ) {
8479             $CPAN::Frontend->myprint(
8480                                      qq{----\n}.
8481                                      qq{  You may have to su }.
8482                                      qq{to root to install the package\n}.
8483                                      qq{  (Or you may want to run something like\n}.
8484                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8485                                      qq{  to raise your permissions.}
8486                                     );
8487         }
8488     }
8489     delete $self->{force_update};
8490     # $DB::single = 1;
8491     $self->store_persistent_state;
8492 }
8493
8494 sub introduce_myself {
8495     my($self) = @_;
8496     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8497 }
8498
8499 #-> sub CPAN::Distribution::dir ;
8500 sub dir {
8501     shift->{build_dir};
8502 }
8503
8504 #-> sub CPAN::Distribution::perldoc ;
8505 sub perldoc {
8506     my($self) = @_;
8507
8508     my($dist) = $self->id;
8509     my $package = $self->called_for;
8510
8511     $self->_display_url( $CPAN::Defaultdocs . $package );
8512 }
8513
8514 #-> sub CPAN::Distribution::_check_binary ;
8515 sub _check_binary {
8516     my ($dist,$shell,$binary) = @_;
8517     my ($pid,$out);
8518
8519     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8520       if $CPAN::DEBUG;
8521
8522     if ($CPAN::META->has_inst("File::Which")) {
8523         return File::Which::which($binary);
8524     } else {
8525         local *README;
8526         $pid = open README, "which $binary|"
8527             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8528         return unless $pid;
8529         while (<README>) {
8530             $out .= $_;
8531         }
8532         close README
8533             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8534                 and return;
8535     }
8536
8537     $CPAN::Frontend->myprint(qq{   + $out \n})
8538       if $CPAN::DEBUG && $out;
8539
8540     return $out;
8541 }
8542
8543 #-> sub CPAN::Distribution::_display_url ;
8544 sub _display_url {
8545     my($self,$url) = @_;
8546     my($res,$saved_file,$pid,$out);
8547
8548     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8549       if $CPAN::DEBUG;
8550
8551     # should we define it in the config instead?
8552     my $html_converter = "html2text";
8553
8554     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8555     my $web_browser_out = $web_browser
8556       ? CPAN::Distribution->_check_binary($self,$web_browser)
8557         : undef;
8558
8559     if ($web_browser_out) {
8560         # web browser found, run the action
8561         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8562         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8563           if $CPAN::DEBUG;
8564         $CPAN::Frontend->myprint(qq{
8565 Displaying URL
8566   $url
8567 with browser $browser
8568 });
8569         $CPAN::Frontend->mysleep(1);
8570         system("$browser $url");
8571         if ($saved_file) { 1 while unlink($saved_file) }
8572     } else {
8573         # web browser not found, let's try text only
8574         my $html_converter_out =
8575           CPAN::Distribution->_check_binary($self,$html_converter);
8576         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8577
8578         if ($html_converter_out ) {
8579             # html2text found, run it
8580             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8581             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8582                 unless defined($saved_file);
8583
8584             local *README;
8585             $pid = open README, "$html_converter $saved_file |"
8586               or $CPAN::Frontend->mydie(qq{
8587 Could not fork '$html_converter $saved_file': $!});
8588             my($fh,$filename);
8589             if ($CPAN::META->has_inst("File::Temp")) {
8590                 $fh = File::Temp->new(
8591                                       template => 'cpan_htmlconvert_XXXX',
8592                                       suffix => '.txt',
8593                                       unlink => 0,
8594                                      );
8595                 $filename = $fh->filename;
8596             } else {
8597                 $filename = "cpan_htmlconvert_$$.txt";
8598                 $fh = FileHandle->new();
8599                 open $fh, ">$filename" or die;
8600             }
8601             while (<README>) {
8602                 $fh->print($_);
8603             }
8604             close README or
8605                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8606             my $tmpin = $fh->filename;
8607             $CPAN::Frontend->myprint(sprintf(qq{
8608 Run '%s %s' and
8609 saved output to %s\n},
8610                                              $html_converter,
8611                                              $saved_file,
8612                                              $tmpin,
8613                                             )) if $CPAN::DEBUG;
8614             close $fh;
8615             local *FH;
8616             open FH, $tmpin
8617                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8618             my $fh_pager = FileHandle->new;
8619             local($SIG{PIPE}) = "IGNORE";
8620             my $pager = $CPAN::Config->{'pager'} || "cat";
8621             $fh_pager->open("|$pager")
8622                 or $CPAN::Frontend->mydie(qq{
8623 Could not open pager '$pager': $!});
8624             $CPAN::Frontend->myprint(qq{
8625 Displaying URL
8626   $url
8627 with pager "$pager"
8628 });
8629             $CPAN::Frontend->mysleep(1);
8630             $fh_pager->print(<FH>);
8631             $fh_pager->close;
8632         } else {
8633             # coldn't find the web browser or html converter
8634             $CPAN::Frontend->myprint(qq{
8635 You need to install lynx or $html_converter to use this feature.});
8636         }
8637     }
8638 }
8639
8640 #-> sub CPAN::Distribution::_getsave_url ;
8641 sub _getsave_url {
8642     my($dist, $shell, $url) = @_;
8643
8644     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8645       if $CPAN::DEBUG;
8646
8647     my($fh,$filename);
8648     if ($CPAN::META->has_inst("File::Temp")) {
8649         $fh = File::Temp->new(
8650                               template => "cpan_getsave_url_XXXX",
8651                               suffix => ".html",
8652                               unlink => 0,
8653                              );
8654         $filename = $fh->filename;
8655     } else {
8656         $fh = FileHandle->new;
8657         $filename = "cpan_getsave_url_$$.html";
8658     }
8659     my $tmpin = $filename;
8660     if ($CPAN::META->has_usable('LWP')) {
8661         $CPAN::Frontend->myprint("Fetching with LWP:
8662   $url
8663 ");
8664         my $Ua;
8665         CPAN::LWP::UserAgent->config;
8666         eval { $Ua = CPAN::LWP::UserAgent->new; };
8667         if ($@) {
8668             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8669             return;
8670         } else {
8671             my($var);
8672             $Ua->proxy('http', $var)
8673                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8674             $Ua->no_proxy($var)
8675                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8676         }
8677
8678         my $req = HTTP::Request->new(GET => $url);
8679         $req->header('Accept' => 'text/html');
8680         my $res = $Ua->request($req);
8681         if ($res->is_success) {
8682             $CPAN::Frontend->myprint(" + request successful.\n")
8683                 if $CPAN::DEBUG;
8684             print $fh $res->content;
8685             close $fh;
8686             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8687                 if $CPAN::DEBUG;
8688             return $tmpin;
8689         } else {
8690             $CPAN::Frontend->myprint(sprintf(
8691                                              "LWP failed with code[%s], message[%s]\n",
8692                                              $res->code,
8693                                              $res->message,
8694                                             ));
8695             return;
8696         }
8697     } else {
8698         $CPAN::Frontend->mywarn("  LWP not available\n");
8699         return;
8700     }
8701 }
8702
8703 # sub CPAN::Distribution::_build_command
8704 sub _build_command {
8705     my($self) = @_;
8706     if ($^O eq "MSWin32") { # special code needed at least up to
8707                             # Module::Build 0.2611 and 0.2706; a fix
8708                             # in M:B has been promised 2006-01-30
8709         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8710         return "$perl ./Build";
8711     }
8712     return "./Build";
8713 }
8714
8715 #-> sub CPAN::Distribution::reports
8716 sub reports {
8717     my($self) = @_;
8718     my $pathname = $self->id;
8719     $CPAN::Frontend->myprint("Distribution: $pathname\n");
8720
8721     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
8722         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
8723     }
8724     unless ($CPAN::META->has_usable("LWP")) {
8725         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
8726     }
8727     unless ($CPAN::META->has_inst("File::Temp")) {
8728         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
8729     }
8730
8731     my $d = CPAN::DistnameInfo->new($pathname);
8732
8733     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
8734     my $version   = $d->version;   # "0.02"
8735     my $maturity  = $d->maturity;  # "released"
8736     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
8737     my $cpanid    = $d->cpanid;    # "GBARR"
8738     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
8739
8740     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
8741
8742     CPAN::LWP::UserAgent->config;
8743     my $Ua;
8744     eval { $Ua = CPAN::LWP::UserAgent->new; };
8745     if ($@) {
8746         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
8747     }
8748     $CPAN::Frontend->myprint("Fetching '$url'...");
8749     my $resp = $Ua->get($url);
8750     unless ($resp->is_success) {
8751         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
8752     }
8753     $CPAN::Frontend->myprint("DONE\n\n");
8754     my $yaml = $resp->content;
8755     # was fuer ein Umweg!
8756     my $fh = File::Temp->new(
8757                              template => 'cpan_reports_XXXX',
8758                              suffix => '.yaml',
8759                              unlink => 0,
8760                             );
8761     my $tfilename = $fh->filename;
8762     print $fh $yaml;
8763     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
8764     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
8765     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
8766     my %other_versions;
8767     my $this_version_seen;
8768     for my $rep (@$unserialized) {
8769         my $rversion = $rep->{version};
8770         if ($rversion eq $version){
8771             unless ($this_version_seen++) {
8772                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
8773             }
8774             $CPAN::Frontend->myprint
8775                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
8776                          $rep->{archname} eq $Config::Config{archname}?"*":"",
8777                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
8778                          $rep->{action},
8779                          $rep->{perl},
8780                          ucfirst $rep->{osname},
8781                          $rep->{osvers},
8782                          $rep->{archname},
8783                         ));
8784         } else {
8785             $other_versions{$rep->{version}}++;
8786         }
8787     }
8788     unless ($this_version_seen) {
8789         $CPAN::Frontend->myprint("No reports found for version '$version'
8790 Reports for other versions:\n");
8791         for my $v (sort keys %other_versions) {
8792             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
8793         }
8794     }
8795     $url =~ s/\.yaml/.html/;
8796     $CPAN::Frontend->myprint("See $url for details\n");
8797 }
8798
8799 package CPAN::Bundle;
8800 use strict;
8801
8802 sub look {
8803     my $self = shift;
8804     $CPAN::Frontend->myprint($self->as_string);
8805 }
8806
8807 #-> CPAN::Bundle::undelay
8808 sub undelay {
8809     my $self = shift;
8810     delete $self->{later};
8811     for my $c ( $self->contains ) {
8812         my $obj = CPAN::Shell->expandany($c) or next;
8813         $obj->undelay;
8814     }
8815 }
8816
8817 # mark as dirty/clean
8818 #-> sub CPAN::Bundle::color_cmd_tmps ;
8819 sub color_cmd_tmps {
8820     my($self) = shift;
8821     my($depth) = shift || 0;
8822     my($color) = shift || 0;
8823     my($ancestors) = shift || [];
8824     # a module needs to recurse to its cpan_file, a distribution needs
8825     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8826
8827     return if exists $self->{incommandcolor}
8828         && $color==1
8829         && $self->{incommandcolor}==$color;
8830     if ($depth>=$CPAN::MAX_RECURSION){
8831         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8832     }
8833     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8834
8835     for my $c ( $self->contains ) {
8836         my $obj = CPAN::Shell->expandany($c) or next;
8837         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8838         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8839     }
8840     # never reached code?
8841     #if ($color==0) {
8842       #delete $self->{badtestcnt};
8843     #}
8844     $self->{incommandcolor} = $color;
8845 }
8846
8847 #-> sub CPAN::Bundle::as_string ;
8848 sub as_string {
8849     my($self) = @_;
8850     $self->contains;
8851     # following line must be "=", not "||=" because we have a moving target
8852     $self->{INST_VERSION} = $self->inst_version;
8853     return $self->SUPER::as_string;
8854 }
8855
8856 #-> sub CPAN::Bundle::contains ;
8857 sub contains {
8858     my($self) = @_;
8859     my($inst_file) = $self->inst_file || "";
8860     my($id) = $self->id;
8861     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8862     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8863         undef $inst_file;
8864     }
8865     unless ($inst_file) {
8866         # Try to get at it in the cpan directory
8867         $self->debug("no inst_file") if $CPAN::DEBUG;
8868         my $cpan_file;
8869         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8870               $cpan_file = $self->cpan_file;
8871         if ($cpan_file eq "N/A") {
8872             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8873   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8874         }
8875         my $dist = $CPAN::META->instance('CPAN::Distribution',
8876                                          $self->cpan_file);
8877         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8878         $dist->get;
8879         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8880         my($todir) = $CPAN::Config->{'cpan_home'};
8881         my(@me,$from,$to,$me);
8882         @me = split /::/, $self->id;
8883         $me[-1] .= ".pm";
8884         $me = File::Spec->catfile(@me);
8885         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8886         $to = File::Spec->catfile($todir,$me);
8887         File::Path::mkpath(File::Basename::dirname($to));
8888         File::Copy::copy($from, $to)
8889               or Carp::confess("Couldn't copy $from to $to: $!");
8890         $inst_file = $to;
8891     }
8892     my @result;
8893     my $fh = FileHandle->new;
8894     local $/ = "\n";
8895     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8896     my $in_cont = 0;
8897     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8898     while (<$fh>) {
8899         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8900             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8901         next unless $in_cont;
8902         next if /^=/;
8903         s/\#.*//;
8904         next if /^\s+$/;
8905         chomp;
8906         push @result, (split " ", $_, 2)[0];
8907     }
8908     close $fh;
8909     delete $self->{STATUS};
8910     $self->{CONTAINS} = \@result;
8911     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8912     unless (@result) {
8913         $CPAN::Frontend->mywarn(qq{
8914 The bundle file "$inst_file" may be a broken
8915 bundlefile. It seems not to contain any bundle definition.
8916 Please check the file and if it is bogus, please delete it.
8917 Sorry for the inconvenience.
8918 });
8919     }
8920     @result;
8921 }
8922
8923 #-> sub CPAN::Bundle::find_bundle_file
8924 # $where is in local format, $what is in unix format
8925 sub find_bundle_file {
8926     my($self,$where,$what) = @_;
8927     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8928 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8929 ###    my $bu = File::Spec->catfile($where,$what);
8930 ###    return $bu if -f $bu;
8931     my $manifest = File::Spec->catfile($where,"MANIFEST");
8932     unless (-f $manifest) {
8933         require ExtUtils::Manifest;
8934         my $cwd = CPAN::anycwd();
8935         $self->safe_chdir($where);
8936         ExtUtils::Manifest::mkmanifest();
8937         $self->safe_chdir($cwd);
8938     }
8939     my $fh = FileHandle->new($manifest)
8940         or Carp::croak("Couldn't open $manifest: $!");
8941     local($/) = "\n";
8942     my $bundle_filename = $what;
8943     $bundle_filename =~ s|Bundle.*/||;
8944     my $bundle_unixpath;
8945     while (<$fh>) {
8946         next if /^\s*\#/;
8947         my($file) = /(\S+)/;
8948         if ($file =~ m|\Q$what\E$|) {
8949             $bundle_unixpath = $file;
8950             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8951             last;
8952         }
8953         # retry if she managed to have no Bundle directory
8954         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8955     }
8956     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8957         if $bundle_unixpath;
8958     Carp::croak("Couldn't find a Bundle file in $where");
8959 }
8960
8961 # needs to work quite differently from Module::inst_file because of
8962 # cpan_home/Bundle/ directory and the possibility that we have
8963 # shadowing effect. As it makes no sense to take the first in @INC for
8964 # Bundles, we parse them all for $VERSION and take the newest.
8965
8966 #-> sub CPAN::Bundle::inst_file ;
8967 sub inst_file {
8968     my($self) = @_;
8969     my($inst_file);
8970     my(@me);
8971     @me = split /::/, $self->id;
8972     $me[-1] .= ".pm";
8973     my($incdir,$bestv);
8974     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8975         my $bfile = File::Spec->catfile($incdir, @me);
8976         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8977         next unless -f $bfile;
8978         my $foundv = MM->parse_version($bfile);
8979         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8980             $self->{INST_FILE} = $bfile;
8981             $self->{INST_VERSION} = $bestv = $foundv;
8982         }
8983     }
8984     $self->{INST_FILE};
8985 }
8986
8987 #-> sub CPAN::Bundle::inst_version ;
8988 sub inst_version {
8989     my($self) = @_;
8990     $self->inst_file; # finds INST_VERSION as side effect
8991     $self->{INST_VERSION};
8992 }
8993
8994 #-> sub CPAN::Bundle::rematein ;
8995 sub rematein {
8996     my($self,$meth) = @_;
8997     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8998     my($id) = $self->id;
8999     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9000         unless $self->inst_file || $self->cpan_file;
9001     my($s,%fail);
9002     for $s ($self->contains) {
9003         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9004             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9005         if ($type eq 'CPAN::Distribution') {
9006             $CPAN::Frontend->mywarn(qq{
9007 The Bundle }.$self->id.qq{ contains
9008 explicitly a file '$s'.
9009 Going to $meth that.
9010 });
9011             $CPAN::Frontend->mysleep(5);
9012         }
9013         # possibly noisy action:
9014         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9015         my $obj = $CPAN::META->instance($type,$s);
9016         $obj->{reqtype} = $self->{reqtype};
9017         $obj->$meth();
9018     }
9019 }
9020
9021 # If a bundle contains another that contains an xs_file we have here,
9022 # we just don't bother I suppose
9023 #-> sub CPAN::Bundle::xs_file
9024 sub xs_file {
9025     return 0;
9026 }
9027
9028 #-> sub CPAN::Bundle::force ;
9029 sub fforce   { shift->rematein('fforce',@_); }
9030 #-> sub CPAN::Bundle::force ;
9031 sub force   { shift->rematein('force',@_); }
9032 #-> sub CPAN::Bundle::notest ;
9033 sub notest  { shift->rematein('notest',@_); }
9034 #-> sub CPAN::Bundle::get ;
9035 sub get     { shift->rematein('get',@_); }
9036 #-> sub CPAN::Bundle::make ;
9037 sub make    { shift->rematein('make',@_); }
9038 #-> sub CPAN::Bundle::test ;
9039 sub test    {
9040     my $self = shift;
9041     # $self->{badtestcnt} ||= 0;
9042     $self->rematein('test',@_);
9043 }
9044 #-> sub CPAN::Bundle::install ;
9045 sub install {
9046   my $self = shift;
9047   $self->rematein('install',@_);
9048 }
9049 #-> sub CPAN::Bundle::clean ;
9050 sub clean   { shift->rematein('clean',@_); }
9051
9052 #-> sub CPAN::Bundle::uptodate ;
9053 sub uptodate {
9054     my($self) = @_;
9055     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9056     my $c;
9057     foreach $c ($self->contains) {
9058         my $obj = CPAN::Shell->expandany($c);
9059         return 0 unless $obj->uptodate;
9060     }
9061     return 1;
9062 }
9063
9064 #-> sub CPAN::Bundle::readme ;
9065 sub readme  {
9066     my($self) = @_;
9067     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9068 No File found for bundle } . $self->id . qq{\n}), return;
9069     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9070     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9071 }
9072
9073 package CPAN::Module;
9074 use strict;
9075
9076 # Accessors
9077 #-> sub CPAN::Module::userid
9078 sub userid {
9079     my $self = shift;
9080     my $ro = $self->ro;
9081     return unless $ro;
9082     return $ro->{userid} || $ro->{CPAN_USERID};
9083 }
9084 #-> sub CPAN::Module::description
9085 sub description {
9086     my $self = shift;
9087     my $ro = $self->ro or return "";
9088     $ro->{description}
9089 }
9090
9091 #-> sub CPAN::Module::distribution
9092 sub distribution {
9093     my($self) = @_;
9094     CPAN::Shell->expand("Distribution",$self->cpan_file);
9095 }
9096
9097 #-> sub CPAN::Module::undelay
9098 sub undelay {
9099     my $self = shift;
9100     delete $self->{later};
9101     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9102         $dist->undelay;
9103     }
9104 }
9105
9106 # mark as dirty/clean
9107 #-> sub CPAN::Module::color_cmd_tmps ;
9108 sub color_cmd_tmps {
9109     my($self) = shift;
9110     my($depth) = shift || 0;
9111     my($color) = shift || 0;
9112     my($ancestors) = shift || [];
9113     # a module needs to recurse to its cpan_file
9114
9115     return if exists $self->{incommandcolor}
9116         && $color==1
9117         && $self->{incommandcolor}==$color;
9118     return if $color==0 && !$self->{incommandcolor};
9119     if ($color>=1) {
9120         if ( $self->uptodate ) {
9121             $self->{incommandcolor} = $color;
9122             return;
9123         } elsif (my $have_version = $self->available_version) {
9124             # maybe what we have is good enough
9125             if (@$ancestors) {
9126                 my $who_asked_for_me = $ancestors->[-1];
9127                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9128                 if (0) {
9129                 } elsif ($obj->isa("CPAN::Bundle")) {
9130                     # bundles cannot specify a minimum version
9131                     return;
9132                 } elsif ($obj->isa("CPAN::Distribution")) {
9133                     if (my $prereq_pm = $obj->prereq_pm) {
9134                         for my $k (keys %$prereq_pm) {
9135                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9136                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9137                                     $self->{incommandcolor} = $color;
9138                                     return;
9139                                 }
9140                             }
9141                         }
9142                     }
9143                 }
9144             }
9145         }
9146     } else {
9147         $self->{incommandcolor} = $color; # set me before recursion,
9148                                           # so we can break it
9149     }
9150     if ($depth>=$CPAN::MAX_RECURSION){
9151         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9152     }
9153     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9154
9155     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9156         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9157     }
9158     # unreached code?
9159     # if ($color==0) {
9160     #    delete $self->{badtestcnt};
9161     # }
9162     $self->{incommandcolor} = $color;
9163 }
9164
9165 #-> sub CPAN::Module::as_glimpse ;
9166 sub as_glimpse {
9167     my($self) = @_;
9168     my(@m);
9169     my $class = ref($self);
9170     $class =~ s/^CPAN:://;
9171     my $color_on = "";
9172     my $color_off = "";
9173     if (
9174         $CPAN::Shell::COLOR_REGISTERED
9175         &&
9176         $CPAN::META->has_inst("Term::ANSIColor")
9177         &&
9178         $self->description
9179        ) {
9180         $color_on = Term::ANSIColor::color("green");
9181         $color_off = Term::ANSIColor::color("reset");
9182     }
9183     my $uptodateness = " ";
9184     if ($class eq "Bundle") {
9185     } elsif ($self->uptodate) {
9186         $uptodateness = "=";
9187     } elsif ($self->inst_version) {
9188         $uptodateness = "<";
9189     }
9190     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9191                      $class,
9192                      $uptodateness,
9193                      $color_on,
9194                      $self->id,
9195                      $color_off,
9196                      ($self->distribution ?
9197                       $self->distribution->pretty_id :
9198                       $self->cpan_userid
9199                      ),
9200                     );
9201     join "", @m;
9202 }
9203
9204 #-> sub CPAN::Module::dslip_status
9205 sub dslip_status {
9206     my($self) = @_;
9207     my($stat);
9208     # development status
9209     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9210                                               pre-alpha alpha beta released
9211                                               mature standard,;
9212     # support level
9213     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9214                                               developer comp.lang.perl.*
9215                                               none abandoned,;
9216     # language
9217     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9218     # interface
9219     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9220                                               references+ties
9221                                               object-oriented pragma
9222                                               hybrid none,;
9223     # public licence
9224     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9225                                               GPL LGPL
9226                                               BSD Artistic
9227                                               open-source
9228                                               distribution_allowed
9229                                               restricted_distribution
9230                                               no_licence,;
9231     for my $x (qw(d s l i p)) {
9232         $stat->{$x}{' '} = 'unknown';
9233         $stat->{$x}{'?'} = 'unknown';
9234     }
9235     my $ro = $self->ro;
9236     return +{} unless $ro && $ro->{statd};
9237     return {
9238             D  => $ro->{statd},
9239             S  => $ro->{stats},
9240             L  => $ro->{statl},
9241             I  => $ro->{stati},
9242             P  => $ro->{statp},
9243             DV => $stat->{D}{$ro->{statd}},
9244             SV => $stat->{S}{$ro->{stats}},
9245             LV => $stat->{L}{$ro->{statl}},
9246             IV => $stat->{I}{$ro->{stati}},
9247             PV => $stat->{P}{$ro->{statp}},
9248            };
9249 }
9250
9251 #-> sub CPAN::Module::as_string ;
9252 sub as_string {
9253     my($self) = @_;
9254     my(@m);
9255     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9256     my $class = ref($self);
9257     $class =~ s/^CPAN:://;
9258     local($^W) = 0;
9259     push @m, $class, " id = $self->{ID}\n";
9260     my $sprintf = "    %-12s %s\n";
9261     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9262         if $self->description;
9263     my $sprintf2 = "    %-12s %s (%s)\n";
9264     my($userid);
9265     $userid = $self->userid;
9266     if ( $userid ){
9267         my $author;
9268         if ($author = CPAN::Shell->expand('Author',$userid)) {
9269           my $email = "";
9270           my $m; # old perls
9271           if ($m = $author->email) {
9272             $email = " <$m>";
9273           }
9274           push @m, sprintf(
9275                            $sprintf2,
9276                            'CPAN_USERID',
9277                            $userid,
9278                            $author->fullname . $email
9279                           );
9280         }
9281     }
9282     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9283         if $self->cpan_version;
9284     if (my $cpan_file = $self->cpan_file){
9285         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9286         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9287             my $upload_date = $dist->upload_date;
9288             if ($upload_date) {
9289                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9290             }
9291         }
9292     }
9293     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9294     my $dslip = $self->dslip_status;
9295     push @m, sprintf(
9296                      $sprintf3,
9297                      'DSLIP_STATUS',
9298                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9299                     ) if $dslip->{D};
9300     my $local_file = $self->inst_file;
9301     unless ($self->{MANPAGE}) {
9302         my $manpage;
9303         if ($local_file) {
9304             $manpage = $self->manpage_headline($local_file);
9305         } else {
9306             # If we have already untarred it, we should look there
9307             my $dist = $CPAN::META->instance('CPAN::Distribution',
9308                                              $self->cpan_file);
9309             # warn "dist[$dist]";
9310             # mff=manifest file; mfh=manifest handle
9311             my($mff,$mfh);
9312             if (
9313                 $dist->{build_dir}
9314                 and
9315                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9316                 and
9317                 $mfh = FileHandle->new($mff)
9318                ) {
9319                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9320                 my $lfre = $self->id; # local file RE
9321                 $lfre =~ s/::/./g;
9322                 $lfre .= "\\.pm\$";
9323                 my($lfl); # local file file
9324                 local $/ = "\n";
9325                 my(@mflines) = <$mfh>;
9326                 for (@mflines) {
9327                     s/^\s+//;
9328                     s/\s.*//s;
9329                 }
9330                 while (length($lfre)>5 and !$lfl) {
9331                     ($lfl) = grep /$lfre/, @mflines;
9332                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9333                     $lfre =~ s/.+?\.//;
9334                 }
9335                 $lfl =~ s/\s.*//; # remove comments
9336                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9337                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9338                 # warn "lfl_abs[$lfl_abs]";
9339                 if (-f $lfl_abs) {
9340                     $manpage = $self->manpage_headline($lfl_abs);
9341                 }
9342             }
9343         }
9344         $self->{MANPAGE} = $manpage if $manpage;
9345     }
9346     my($item);
9347     for $item (qw/MANPAGE/) {
9348         push @m, sprintf($sprintf, $item, $self->{$item})
9349             if exists $self->{$item};
9350     }
9351     for $item (qw/CONTAINS/) {
9352         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9353             if exists $self->{$item} && @{$self->{$item}};
9354     }
9355     push @m, sprintf($sprintf, 'INST_FILE',
9356                      $local_file || "(not installed)");
9357     push @m, sprintf($sprintf, 'INST_VERSION',
9358                      $self->inst_version) if $local_file;
9359     join "", @m, "\n";
9360 }
9361
9362 #-> sub CPAN::Module::manpage_headline
9363 sub manpage_headline {
9364   my($self,$local_file) = @_;
9365   my(@local_file) = $local_file;
9366   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9367   push @local_file, $local_file;
9368   my(@result,$locf);
9369   for $locf (@local_file) {
9370     next unless -f $locf;
9371     my $fh = FileHandle->new($locf)
9372         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9373     my $inpod = 0;
9374     local $/ = "\n";
9375     while (<$fh>) {
9376       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9377           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9378       next unless $inpod;
9379       next if /^=/;
9380       next if /^\s+$/;
9381       chomp;
9382       push @result, $_;
9383     }
9384     close $fh;
9385     last if @result;
9386   }
9387   for (@result) {
9388       s/^\s+//;
9389       s/\s+$//;
9390   }
9391   join " ", @result;
9392 }
9393
9394 #-> sub CPAN::Module::cpan_file ;
9395 # Note: also inherited by CPAN::Bundle
9396 sub cpan_file {
9397     my $self = shift;
9398     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9399     unless ($self->ro) {
9400         CPAN::Index->reload;
9401     }
9402     my $ro = $self->ro;
9403     if ($ro && defined $ro->{CPAN_FILE}){
9404         return $ro->{CPAN_FILE};
9405     } else {
9406         my $userid = $self->userid;
9407         if ( $userid ) {
9408             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9409                 my $author = $CPAN::META->instance("CPAN::Author",
9410                                                    $userid);
9411                 my $fullname = $author->fullname;
9412                 my $email = $author->email;
9413                 unless (defined $fullname && defined $email) {
9414                     return sprintf("Contact Author %s",
9415                                    $userid,
9416                                   );
9417                 }
9418                 return "Contact Author $fullname <$email>";
9419             } else {
9420                 return "Contact Author $userid (Email address not available)";
9421             }
9422         } else {
9423             return "N/A";
9424         }
9425     }
9426 }
9427
9428 #-> sub CPAN::Module::cpan_version ;
9429 sub cpan_version {
9430     my $self = shift;
9431
9432     my $ro = $self->ro;
9433     unless ($ro) {
9434         # Can happen with modules that are not on CPAN
9435         $ro = {};
9436     }
9437     $ro->{CPAN_VERSION} = 'undef'
9438         unless defined $ro->{CPAN_VERSION};
9439     $ro->{CPAN_VERSION};
9440 }
9441
9442 #-> sub CPAN::Module::force ;
9443 sub force {
9444     my($self) = @_;
9445     $self->{force_update} = 1;
9446 }
9447
9448 #-> sub CPAN::Module::fforce ;
9449 sub fforce {
9450     my($self) = @_;
9451     $self->{force_update} = 2;
9452 }
9453
9454 #-> sub CPAN::Module::notest ;
9455 sub notest {
9456     my($self) = @_;
9457     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
9458     $self->{notest}++;
9459 }
9460
9461 #-> sub CPAN::Module::rematein ;
9462 sub rematein {
9463     my($self,$meth) = @_;
9464     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9465                                      $meth,
9466                                      $self->id));
9467     my $cpan_file = $self->cpan_file;
9468     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9469       $CPAN::Frontend->mywarn(sprintf qq{
9470   The module %s isn\'t available on CPAN.
9471
9472   Either the module has not yet been uploaded to CPAN, or it is
9473   temporary unavailable. Please contact the author to find out
9474   more about the status. Try 'i %s'.
9475 },
9476                               $self->id,
9477                               $self->id,
9478                              );
9479       return;
9480     }
9481     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9482     $pack->called_for($self->id);
9483     if (exists $self->{force_update}){
9484         if ($self->{force_update} == 2) {
9485             $pack->fforce($meth);
9486         } else {
9487             $pack->force($meth);
9488         }
9489     }
9490     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
9491
9492     $pack->{reqtype} ||= "";
9493     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9494                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9495         if ($pack->{reqtype}) {
9496             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9497                 $pack->{reqtype} = $self->{reqtype};
9498                 if (
9499                     exists $pack->{install}
9500                     &&
9501                     (
9502                      UNIVERSAL::can($pack->{install},"failed") ?
9503                      $pack->{install}->failed :
9504                      $pack->{install} =~ /^NO/
9505                     )
9506                    ) {
9507                     delete $pack->{install};
9508                     $CPAN::Frontend->mywarn
9509                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9510                 }
9511             }
9512         } else {
9513             $pack->{reqtype} = $self->{reqtype};
9514         }
9515
9516     my $success = eval {
9517         $pack->$meth();
9518     };
9519     my $err = $@;
9520     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9521     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
9522     delete $self->{force_update};
9523     delete $self->{notest};
9524     if ($err) {
9525         die $err;
9526     }
9527     return $success;
9528 }
9529
9530 #-> sub CPAN::Module::perldoc ;
9531 sub perldoc { shift->rematein('perldoc') }
9532 #-> sub CPAN::Module::readme ;
9533 sub readme  { shift->rematein('readme') }
9534 #-> sub CPAN::Module::look ;
9535 sub look    { shift->rematein('look') }
9536 #-> sub CPAN::Module::cvs_import ;
9537 sub cvs_import { shift->rematein('cvs_import') }
9538 #-> sub CPAN::Module::get ;
9539 sub get     { shift->rematein('get',@_) }
9540 #-> sub CPAN::Module::make ;
9541 sub make    { shift->rematein('make') }
9542 #-> sub CPAN::Module::test ;
9543 sub test   {
9544     my $self = shift;
9545     # $self->{badtestcnt} ||= 0;
9546     $self->rematein('test',@_);
9547 }
9548 #-> sub CPAN::Module::uptodate ;
9549 sub uptodate {
9550     my($self) = @_;
9551     local($_); # protect against a bug in MakeMaker 6.17
9552     my($latest) = $self->cpan_version;
9553     $latest ||= 0;
9554     my($inst_file) = $self->inst_file;
9555     my($have) = 0;
9556     if (defined $inst_file) {
9557         $have = $self->inst_version;
9558     }
9559     local($^W)=0;
9560     if ($inst_file
9561         &&
9562         ! CPAN::Version->vgt($latest, $have)
9563        ) {
9564         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9565                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9566         return 1;
9567     }
9568     return;
9569 }
9570 #-> sub CPAN::Module::install ;
9571 sub install {
9572     my($self) = @_;
9573     my($doit) = 0;
9574     if ($self->uptodate
9575         &&
9576         not exists $self->{force_update}
9577        ) {
9578         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9579                                          $self->id,
9580                                          $self->inst_version,
9581                                         ));
9582     } else {
9583         $doit = 1;
9584     }
9585     my $ro = $self->ro;
9586     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9587         $CPAN::Frontend->mywarn(qq{
9588 \n\n\n     ***WARNING***
9589      The module $self->{ID} has no active maintainer.\n\n\n
9590 });
9591         $CPAN::Frontend->mysleep(5);
9592     }
9593     $self->rematein('install') if $doit;
9594 }
9595 #-> sub CPAN::Module::clean ;
9596 sub clean  { shift->rematein('clean') }
9597
9598 #-> sub CPAN::Module::inst_file ;
9599 sub inst_file {
9600     my($self) = @_;
9601     $self->_file_in_path([@INC]);
9602 }
9603
9604 #-> sub CPAN::Module::available_file ;
9605 sub available_file {
9606     my($self) = @_;
9607     my $sep = $Config::Config{path_sep};
9608     my $perllib = $ENV{PERL5LIB};
9609     $perllib = $ENV{PERLLIB} unless defined $perllib;
9610     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9611     $self->_file_in_path([@perllib,@INC]);
9612 }
9613
9614 #-> sub CPAN::Module::file_in_path ;
9615 sub _file_in_path {
9616     my($self,$path) = @_;
9617     my($dir,@packpath);
9618     @packpath = split /::/, $self->{ID};
9619     $packpath[-1] .= ".pm";
9620     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9621         unshift @packpath, "Term", "ReadLine"; # historical reasons
9622     }
9623     foreach $dir (@$path) {
9624         my $pmfile = File::Spec->catfile($dir,@packpath);
9625         if (-f $pmfile){
9626             return $pmfile;
9627         }
9628     }
9629     return;
9630 }
9631
9632 #-> sub CPAN::Module::xs_file ;
9633 sub xs_file {
9634     my($self) = @_;
9635     my($dir,@packpath);
9636     @packpath = split /::/, $self->{ID};
9637     push @packpath, $packpath[-1];
9638     $packpath[-1] .= "." . $Config::Config{'dlext'};
9639     foreach $dir (@INC) {
9640         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9641         if (-f $xsfile){
9642             return $xsfile;
9643         }
9644     }
9645     return;
9646 }
9647
9648 #-> sub CPAN::Module::inst_version ;
9649 sub inst_version {
9650     my($self) = @_;
9651     my $parsefile = $self->inst_file or return;
9652     my $have = $self->parse_version($parsefile);
9653     $have;
9654 }
9655
9656 #-> sub CPAN::Module::inst_version ;
9657 sub available_version {
9658     my($self) = @_;
9659     my $parsefile = $self->available_file or return;
9660     my $have = $self->parse_version($parsefile);
9661     $have;
9662 }
9663
9664 #-> sub CPAN::Module::parse_version ;
9665 sub parse_version {
9666     my($self,$parsefile) = @_;
9667     my $have = MM->parse_version($parsefile);
9668     $have = "undef" unless defined $have && length $have;
9669     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9670     $have =~ s/ $//; # trailing whitespace happens all the time
9671
9672     $have = CPAN::Version->readable($have);
9673
9674     $have =~ s/\s*//g; # stringify to float around floating point issues
9675     $have; # no stringify needed, \s* above matches always
9676 }
9677
9678 #-> sub CPAN::Module::reports
9679 sub reports {
9680     my($self) = @_;
9681     $self->distribution->reports;
9682 }
9683
9684 package CPAN;
9685 use strict;
9686
9687 1;
9688
9689
9690 __END__
9691
9692 =head1 NAME
9693
9694 CPAN - query, download and build perl modules from CPAN sites
9695
9696 =head1 SYNOPSIS
9697
9698 Interactive mode:
9699
9700   perl -MCPAN -e shell
9701
9702 --or--
9703
9704   cpan
9705
9706 Basic commands:
9707
9708   # Modules:
9709
9710   cpan> install Acme::Meta                       # in the shell
9711
9712   CPAN::Shell->install("Acme::Meta");            # in perl
9713
9714   # Distributions:
9715
9716   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9717
9718   CPAN::Shell->
9719     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9720
9721   # module objects:
9722
9723   $mo = CPAN::Shell->expandany($mod);
9724   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9725
9726   # distribution objects:
9727
9728   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9729   $do = CPAN::Shell->expandany($distro);         # same thing
9730   $do = CPAN::Shell->expand("Distribution",
9731                             $distro);            # same thing
9732
9733 =head1 DESCRIPTION
9734
9735 The CPAN module automates or at least simplifies the make and install
9736 of perl modules and extensions. It includes some primitive searching
9737 capabilities and knows how to use Net::FTP or LWP or some external
9738 download clients to fetch the distributions from the net.
9739
9740 These are fetched from one or more of the mirrored CPAN (Comprehensive
9741 Perl Archive Network) sites and unpacked in a dedicated directory.
9742
9743 The CPAN module also supports the concept of named and versioned
9744 I<bundles> of modules. Bundles simplify the handling of sets of
9745 related modules. See Bundles below.
9746
9747 The package contains a session manager and a cache manager. The
9748 session manager keeps track of what has been fetched, built and
9749 installed in the current session. The cache manager keeps track of the
9750 disk space occupied by the make processes and deletes excess space
9751 according to a simple FIFO mechanism.
9752
9753 All methods provided are accessible in a programmer style and in an
9754 interactive shell style.
9755
9756 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9757
9758 The interactive mode is entered by running
9759
9760     perl -MCPAN -e shell
9761
9762 or
9763
9764     cpan
9765
9766 which puts you into a readline interface. If C<Term::ReadKey> and
9767 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9768 it supports both history and command completion.
9769
9770 Once you are on the command line, type C<h> to get a one page help
9771 screen and the rest should be self-explanatory.
9772
9773 The function call C<shell> takes two optional arguments, one is the
9774 prompt, the second is the default initial command line (the latter
9775 only works if a real ReadLine interface module is installed).
9776
9777 The most common uses of the interactive modes are
9778
9779 =over 2
9780
9781 =item Searching for authors, bundles, distribution files and modules
9782
9783 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9784 for each of the four categories and another, C<i> for any of the
9785 mentioned four. Each of the four entities is implemented as a class
9786 with slightly differing methods for displaying an object.
9787
9788 Arguments you pass to these commands are either strings exactly matching
9789 the identification string of an object or regular expressions that are
9790 then matched case-insensitively against various attributes of the
9791 objects. The parser recognizes a regular expression only if you
9792 enclose it between two slashes.
9793
9794 The principle is that the number of found objects influences how an
9795 item is displayed. If the search finds one item, the result is
9796 displayed with the rather verbose method C<as_string>, but if we find
9797 more than one, we display each object with the terse method
9798 C<as_glimpse>.
9799
9800 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9801
9802 These commands take any number of arguments and investigate what is
9803 necessary to perform the action. If the argument is a distribution
9804 file name (recognized by embedded slashes), it is processed. If it is
9805 a module, CPAN determines the distribution file in which this module
9806 is included and processes that, following any dependencies named in
9807 the module's META.yml or Makefile.PL (this behavior is controlled by
9808 the configuration parameter C<prerequisites_policy>.)
9809
9810 C<get> downloads a distribution file and untars or unzips it, C<make>
9811 builds it, C<test> runs the test suite, and C<install> installs it.
9812
9813 Any C<make> or C<test> are run unconditionally. An
9814
9815   install <distribution_file>
9816
9817 also is run unconditionally. But for
9818
9819   install <module>
9820
9821 CPAN checks if an install is actually needed for it and prints
9822 I<module up to date> in the case that the distribution file containing
9823 the module doesn't need to be updated.
9824
9825 CPAN also keeps track of what it has done within the current session
9826 and doesn't try to build a package a second time regardless if it
9827 succeeded or not. It does not repeat a test run if the test
9828 has been run successfully before. Same for install runs.
9829
9830 The C<force> pragma may precede another command (currently: C<get>,
9831 C<make>, C<test>, or C<install>) and executes the command from scratch
9832 and tries to continue in case of some errors. See the section below on
9833 the C<force> and the C<fforce> pragma.
9834
9835 The C<notest> pragma may be used to skip the test part in the build
9836 process.
9837
9838 Example:
9839
9840     cpan> notest install Tk
9841
9842 A C<clean> command results in a
9843
9844   make clean
9845
9846 being executed within the distribution file's working directory.
9847
9848 =item C<readme>, C<perldoc>, C<look> module or distribution
9849
9850 C<readme> displays the README file of the associated distribution.
9851 C<Look> gets and untars (if not yet done) the distribution file,
9852 changes to the appropriate directory and opens a subshell process in
9853 that directory. C<perldoc> displays the pod documentation of the
9854 module in html or plain text format.
9855
9856 =item C<ls> author
9857
9858 =item C<ls> globbing_expression
9859
9860 The first form lists all distribution files in and below an author's
9861 CPAN directory as they are stored in the CHECKUMS files distributed on
9862 CPAN. The listing goes recursive into all subdirectories.
9863
9864 The second form allows to limit or expand the output with shell
9865 globbing as in the following examples:
9866
9867           ls JV/make*
9868           ls GSAR/*make*
9869           ls */*make*
9870
9871 The last example is very slow and outputs extra progress indicators
9872 that break the alignment of the result.
9873
9874 Note that globbing only lists directories explicitly asked for, for
9875 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9876 regarded as a bug and may be changed in future versions.
9877
9878 =item C<failed>
9879
9880 The C<failed> command reports all distributions that failed on one of
9881 C<make>, C<test> or C<install> for some reason in the currently
9882 running shell session.
9883
9884 =item Persistence between sessions
9885
9886 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9887 the internal state of all modules is written to disk after each step.
9888 The files contain a signature of the currently running perl version
9889 for later perusal.
9890
9891 If the configurations variable C<build_dir_reuse> is set to a true
9892 value, then CPAN.pm reads the collected YAML files. If the stored
9893 signature matches the currently running perl the stored state is
9894 loaded into memory such that effectively persistence between sessions
9895 is established.
9896
9897 =item The C<force> and the C<fforce> pragma
9898
9899 To speed things up in complex installation scenarios, CPAN.pm keeps
9900 track of what it has already done and refuses to do some things a
9901 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9902 A C<test> is only repeated if the previous test was unsuccessful. The
9903 diagnostic message when CPAN.pm refuses to do something a second time
9904 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9905 something similar. Another situation where CPAN refuses to act is an
9906 C<install> if the according C<test> was not successful.
9907
9908 In all these cases, the user can override the goatish behaviour by
9909 prepending the command with the word force, for example:
9910
9911   cpan> force get Foo
9912   cpan> force make AUTHOR/Bar-3.14.tar.gz
9913   cpan> force test Baz
9914   cpan> force install Acme::Meta
9915
9916 Each I<forced> command is executed with the according part of its
9917 memory erased.
9918
9919 The C<fforce> pragma is a variant that emulates a C<force get> which
9920 erases the entire memory followed by the action specified, effectively
9921 restarting the whole get/make/test/install procedure from scratch.
9922
9923 =item Lockfile
9924
9925 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9926 Batch jobs can run without a lockfile and do not disturb each other.
9927
9928 The shell offers to run in I<degraded mode> when another process is
9929 holding the lockfile. This is an experimental feature that is not yet
9930 tested very well. This second shell then does not write the history
9931 file, does not use the metadata file and has a different prompt.
9932
9933 =item Signals
9934
9935 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9936 in the cpan-shell it is intended that you can press C<^C> anytime and
9937 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9938 to clean up and leave the shell loop. You can emulate the effect of a
9939 SIGTERM by sending two consecutive SIGINTs, which usually means by
9940 pressing C<^C> twice.
9941
9942 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9943 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9944 Build.PL> subprocess.
9945
9946 =back
9947
9948 =head2 CPAN::Shell
9949
9950 The commands that are available in the shell interface are methods in
9951 the package CPAN::Shell. If you enter the shell command, all your
9952 input is split by the Text::ParseWords::shellwords() routine which
9953 acts like most shells do. The first word is being interpreted as the
9954 method to be called and the rest of the words are treated as arguments
9955 to this method. Continuation lines are supported if a line ends with a
9956 literal backslash.
9957
9958 =head2 autobundle
9959
9960 C<autobundle> writes a bundle file into the
9961 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9962 a list of all modules that are both available from CPAN and currently
9963 installed within @INC. The name of the bundle file is based on the
9964 current date and a counter.
9965
9966 =head2 hosts
9967
9968 Note: this feature is still in alpha state and may change in future
9969 versions of CPAN.pm
9970
9971 This commands provides a statistical overview over recent download
9972 activities. The data for this is collected in the YAML file
9973 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9974 configured or YAML not installed, then no stats are provided.
9975
9976 =head2 mkmyconfig
9977
9978 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9979 directory so that you can save your own preferences instead of the
9980 system wide ones.
9981
9982 =head2 recompile
9983
9984 recompile() is a very special command in that it takes no argument and
9985 runs the make/test/install cycle with brute force over all installed
9986 dynamically loadable extensions (aka XS modules) with 'force' in
9987 effect. The primary purpose of this command is to finish a network
9988 installation. Imagine, you have a common source tree for two different
9989 architectures. You decide to do a completely independent fresh
9990 installation. You start on one architecture with the help of a Bundle
9991 file produced earlier. CPAN installs the whole Bundle for you, but
9992 when you try to repeat the job on the second architecture, CPAN
9993 responds with a C<"Foo up to date"> message for all modules. So you
9994 invoke CPAN's recompile on the second architecture and you're done.
9995
9996 Another popular use for C<recompile> is to act as a rescue in case your
9997 perl breaks binary compatibility. If one of the modules that CPAN uses
9998 is in turn depending on binary compatibility (so you cannot run CPAN
9999 commands), then you should try the CPAN::Nox module for recovery.
10000
10001 =head2 report Bundle|Distribution|Module
10002
10003 The C<report> command temporarily turns on the C<test_report> config
10004 variable, then runs the C<force test> command with the given
10005 arguments. The C<force> pragma is used to re-run the tests and repeat
10006 every step that might have failed before.
10007
10008 =head2 upgrade [Module|/Regex/]...
10009
10010 The C<upgrade> command first runs an C<r> command with the given
10011 arguments and then installs the newest versions of all modules that
10012 were listed by that.
10013
10014 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10015
10016 Although it may be considered internal, the class hierarchy does matter
10017 for both users and programmer. CPAN.pm deals with above mentioned four
10018 classes, and all those classes share a set of methods. A classical
10019 single polymorphism is in effect. A metaclass object registers all
10020 objects of all kinds and indexes them with a string. The strings
10021 referencing objects have a separated namespace (well, not completely
10022 separated):
10023
10024          Namespace                         Class
10025
10026    words containing a "/" (slash)      Distribution
10027     words starting with Bundle::          Bundle
10028           everything else            Module or Author
10029
10030 Modules know their associated Distribution objects. They always refer
10031 to the most recent official release. Developers may mark their releases
10032 as unstable development versions (by inserting an underbar into the
10033 module version number which will also be reflected in the distribution
10034 name when you run 'make dist'), so the really hottest and newest
10035 distribution is not always the default.  If a module Foo circulates
10036 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10037 way to install version 1.23 by saying
10038
10039     install Foo
10040
10041 This would install the complete distribution file (say
10042 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10043 like to install version 1.23_90, you need to know where the
10044 distribution file resides on CPAN relative to the authors/id/
10045 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10046 so you would have to say
10047
10048     install BAR/Foo-1.23_90.tar.gz
10049
10050 The first example will be driven by an object of the class
10051 CPAN::Module, the second by an object of class CPAN::Distribution.
10052
10053 =head2 Integrating local directories
10054
10055 Note: this feature is still in alpha state and may change in future
10056 versions of CPAN.pm
10057
10058 Distribution objects are normally distributions from the CPAN, but
10059 there is a slightly degenerate case for Distribution objects, too, of
10060 projects held on the local disk. These distribution objects have the
10061 same name as the local directory and end with a dot. A dot by itself
10062 is also allowed for the current directory at the time CPAN.pm was
10063 used. All actions such as C<make>, C<test>, and C<install> are applied
10064 directly to that directory. This gives the command C<cpan .> an
10065 interesting touch: while the normal mantra of installing a CPAN module
10066 without CPAN.pm is one of
10067
10068     perl Makefile.PL                 perl Build.PL
10069            ( go and get prerequisites )
10070     make                             ./Build
10071     make test                        ./Build test
10072     make install                     ./Build install
10073
10074 the command C<cpan .> does all of this at once. It figures out which
10075 of the two mantras is appropriate, fetches and installs all
10076 prerequisites, cares for them recursively and finally finishes the
10077 installation of the module in the current directory, be it a CPAN
10078 module or not.
10079
10080 The typical usage case is for private modules or working copies of
10081 projects from remote repositories on the local disk.
10082
10083 =head1 CONFIGURATION
10084
10085 When the CPAN module is used for the first time, a configuration
10086 dialog tries to determine a couple of site specific options. The
10087 result of the dialog is stored in a hash reference C< $CPAN::Config >
10088 in a file CPAN/Config.pm.
10089
10090 The default values defined in the CPAN/Config.pm file can be
10091 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10092 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10093 added to the search path of the CPAN module before the use() or
10094 require() statements. The mkmyconfig command writes this file for you.
10095
10096 The C<o conf> command has various bells and whistles:
10097
10098 =over
10099
10100 =item completion support
10101
10102 If you have a ReadLine module installed, you can hit TAB at any point
10103 of the commandline and C<o conf> will offer you completion for the
10104 built-in subcommands and/or config variable names.
10105
10106 =item displaying some help: o conf help
10107
10108 Displays a short help
10109
10110 =item displaying current values: o conf [KEY]
10111
10112 Displays the current value(s) for this config variable. Without KEY
10113 displays all subcommands and config variables.
10114
10115 Example:
10116
10117   o conf shell
10118
10119 =item changing of scalar values: o conf KEY VALUE
10120
10121 Sets the config variable KEY to VALUE. The empty string can be
10122 specified as usual in shells, with C<''> or C<"">
10123
10124 Example:
10125
10126   o conf wget /usr/bin/wget
10127
10128 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10129
10130 If a config variable name ends with C<list>, it is a list. C<o conf
10131 KEY shift> removes the first element of the list, C<o conf KEY pop>
10132 removes the last element of the list. C<o conf KEYS unshift LIST>
10133 prepends a list of values to the list, C<o conf KEYS push LIST>
10134 appends a list of valued to the list.
10135
10136 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10137 splice command.
10138
10139 Finally, any other list of arguments is taken as a new list value for
10140 the KEY variable discarding the previous value.
10141
10142 Examples:
10143
10144   o conf urllist unshift http://cpan.dev.local/CPAN
10145   o conf urllist splice 3 1
10146   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10147
10148 =item reverting to saved: o conf defaults
10149
10150 Reverts all config variables to the state in the saved config file.
10151
10152 =item saving the config: o conf commit
10153
10154 Saves all config variables to the current config file (CPAN/Config.pm
10155 or CPAN/MyConfig.pm that was loaded at start).
10156
10157 =back
10158
10159 The configuration dialog can be started any time later again by
10160 issuing the command C< o conf init > in the CPAN shell. A subset of
10161 the configuration dialog can be run by issuing C<o conf init WORD>
10162 where WORD is any valid config variable or a regular expression.
10163
10164 =head2 Config Variables
10165
10166 Currently the following keys in the hash reference $CPAN::Config are
10167 defined:
10168
10169   applypatch         path to external prg
10170   auto_commit        commit all changes to config variables to disk
10171   build_cache        size of cache for directories to build modules
10172   build_dir          locally accessible directory to build modules
10173   build_dir_reuse    boolean if distros in build_dir are persistent
10174   build_requires_install_policy
10175                      to install or not to install when a module is
10176                      only needed for building. yes|no|ask/yes|ask/no
10177   bzip2              path to external prg
10178   cache_metadata     use serializer to cache metadata
10179   commands_quote     prefered character to use for quoting external
10180                      commands when running them. Defaults to double
10181                      quote on Windows, single tick everywhere else;
10182                      can be set to space to disable quoting
10183   check_sigs         if signatures should be verified
10184   colorize_debug     Term::ANSIColor attributes for debugging output
10185   colorize_output    boolean if Term::ANSIColor should colorize output
10186   colorize_print     Term::ANSIColor attributes for normal output
10187   colorize_warn      Term::ANSIColor attributes for warnings
10188   commandnumber_in_prompt
10189                      boolean if you want to see current command number
10190   cpan_home          local directory reserved for this package
10191   curl               path to external prg
10192   dontload_hash      DEPRECATED
10193   dontload_list      arrayref: modules in the list will not be
10194                      loaded by the CPAN::has_inst() routine
10195   ftp                path to external prg
10196   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10197   ftp_proxy          proxy host for ftp requests
10198   getcwd             see below
10199   gpg                path to external prg
10200   gzip               location of external program gzip
10201   histfile           file to maintain history between sessions
10202   histsize           maximum number of lines to keep in histfile
10203   http_proxy         proxy host for http requests
10204   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10205                      after this many seconds inactivity. Set to 0 to
10206                      never break.
10207   index_expire       after this many days refetch index files
10208   inhibit_startup_message
10209                      if true, does not print the startup message
10210   keep_source_where  directory in which to keep the source (if we do)
10211   lynx               path to external prg
10212   make               location of external make program
10213   make_arg           arguments that should always be passed to 'make'
10214   make_install_make_command
10215                      the make command for running 'make install', for
10216                      example 'sudo make'
10217   make_install_arg   same as make_arg for 'make install'
10218   makepl_arg         arguments passed to 'perl Makefile.PL'
10219   mbuild_arg         arguments passed to './Build'
10220   mbuild_install_arg arguments passed to './Build install'
10221   mbuild_install_build_command
10222                      command to use instead of './Build' when we are
10223                      in the install stage, for example 'sudo ./Build'
10224   mbuildpl_arg       arguments passed to 'perl Build.PL'
10225   ncftp              path to external prg
10226   ncftpget           path to external prg
10227   no_proxy           don't proxy to these hosts/domains (comma separated list)
10228   pager              location of external program more (or any pager)
10229   password           your password if you CPAN server wants one
10230   patch              path to external prg
10231   prefer_installer   legal values are MB and EUMM: if a module comes
10232                      with both a Makefile.PL and a Build.PL, use the
10233                      former (EUMM) or the latter (MB); if the module
10234                      comes with only one of the two, that one will be
10235                      used in any case
10236   prerequisites_policy
10237                      what to do if you are missing module prerequisites
10238                      ('follow' automatically, 'ask' me, or 'ignore')
10239   prefs_dir          local directory to store per-distro build options
10240   proxy_user         username for accessing an authenticating proxy
10241   proxy_pass         password for accessing an authenticating proxy
10242   randomize_urllist  add some randomness to the sequence of the urllist
10243   scan_cache         controls scanning of cache ('atstart' or 'never')
10244   shell              your favorite shell
10245   show_upload_date   boolean if commands should try to determine upload date
10246   tar                location of external program tar
10247   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10248                      (and nonsense for characters outside latin range)
10249   term_ornaments     boolean to turn ReadLine ornamenting on/off
10250   test_report        email test reports (if CPAN::Reporter is installed)
10251   unzip              location of external program unzip
10252   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10253   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10254   username           your username if you CPAN server wants one
10255   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10256   wget               path to external prg
10257   yaml_module        which module to use to read/write YAML files
10258
10259 You can set and query each of these options interactively in the cpan
10260 shell with the C<o conf> or the C<o conf init> command as specified below.
10261
10262 =over 2
10263
10264 =item C<o conf E<lt>scalar optionE<gt>>
10265
10266 prints the current value of the I<scalar option>
10267
10268 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10269
10270 Sets the value of the I<scalar option> to I<value>
10271
10272 =item C<o conf E<lt>list optionE<gt>>
10273
10274 prints the current value of the I<list option> in MakeMaker's
10275 neatvalue format.
10276
10277 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10278
10279 shifts or pops the array in the I<list option> variable
10280
10281 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10282
10283 works like the corresponding perl commands.
10284
10285 =item interactive editing: o conf init [MATCH|LIST]
10286
10287 Runs an interactive configuration dialog for matching variables.
10288 Without argument runs the dialog over all supported config variables.
10289 To specify a MATCH the argument must be enclosed by slashes.
10290
10291 Examples:
10292
10293   o conf init ftp_passive ftp_proxy
10294   o conf init /color/
10295
10296 Note: this method of setting config variables often provides more
10297 explanation about the functioning of a variable than the manpage.
10298
10299 =back
10300
10301 =head2 CPAN::anycwd($path): Note on config variable getcwd
10302
10303 CPAN.pm changes the current working directory often and needs to
10304 determine its own current working directory. Per default it uses
10305 Cwd::cwd but if this doesn't work on your system for some reason,
10306 alternatives can be configured according to the following table:
10307
10308 =over 4
10309
10310 =item cwd
10311
10312 Calls Cwd::cwd
10313
10314 =item getcwd
10315
10316 Calls Cwd::getcwd
10317
10318 =item fastcwd
10319
10320 Calls Cwd::fastcwd
10321
10322 =item backtickcwd
10323
10324 Calls the external command cwd.
10325
10326 =back
10327
10328 =head2 Note on the format of the urllist parameter
10329
10330 urllist parameters are URLs according to RFC 1738. We do a little
10331 guessing if your URL is not compliant, but if you have problems with
10332 C<file> URLs, please try the correct format. Either:
10333
10334     file://localhost/whatever/ftp/pub/CPAN/
10335
10336 or
10337
10338     file:///home/ftp/pub/CPAN/
10339
10340 =head2 The urllist parameter has CD-ROM support
10341
10342 The C<urllist> parameter of the configuration table contains a list of
10343 URLs that are to be used for downloading. If the list contains any
10344 C<file> URLs, CPAN always tries to get files from there first. This
10345 feature is disabled for index files. So the recommendation for the
10346 owner of a CD-ROM with CPAN contents is: include your local, possibly
10347 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10348
10349   o conf urllist push file://localhost/CDROM/CPAN
10350
10351 CPAN.pm will then fetch the index files from one of the CPAN sites
10352 that come at the beginning of urllist. It will later check for each
10353 module if there is a local copy of the most recent version.
10354
10355 Another peculiarity of urllist is that the site that we could
10356 successfully fetch the last file from automatically gets a preference
10357 token and is tried as the first site for the next request. So if you
10358 add a new site at runtime it may happen that the previously preferred
10359 site will be tried another time. This means that if you want to disallow
10360 a site for the next transfer, it must be explicitly removed from
10361 urllist.
10362
10363 =head2 Maintaining the urllist parameter
10364
10365 If you have YAML.pm (or some other YAML module configured in
10366 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10367 about recent downloads. You can view the statistics with the C<hosts>
10368 command or inspect them directly by looking into the C<FTPstats.yml>
10369 file in your C<cpan_home> directory.
10370
10371 To get some interesting statistics it is recommended to set the
10372 C<randomize_urllist> parameter that introduces some amount of
10373 randomness into the URL selection.
10374
10375 =head2 The C<requires> and C<build_requires> dependency declarations
10376
10377 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10378 a distribution are treated differently depending on the config
10379 variable C<build_requires_install_policy>. By setting
10380 C<build_requires_install_policy> to C<no> such a module is not being
10381 installed. It is only built and tested and then kept in the list of
10382 tested but uninstalled modules. As such it is available during the
10383 build of the dependent module by integrating the path to the
10384 C<blib/arch> and C<blib/lib> directories in the environment variable
10385 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10386 both modules declared as C<requires> and those declared as
10387 C<build_requires> are treated alike. By setting to C<ask/yes> or
10388 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10389
10390 =head2 Configuration for individual distributions (I<Distroprefs>)
10391
10392 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10393 still considered beta quality)
10394
10395 Distributions on the CPAN usually behave according to what we call the
10396 CPAN mantra. Or since the event of Module::Build we should talk about
10397 two mantras:
10398
10399     perl Makefile.PL     perl Build.PL
10400     make                 ./Build
10401     make test            ./Build test
10402     make install         ./Build install
10403
10404 But some modules cannot be built with this mantra. They try to get
10405 some extra data from the user via the environment, extra arguments or
10406 interactively thus disturbing the installation of large bundles like
10407 Phalanx100 or modules with many dependencies like Plagger.
10408
10409 The distroprefs system of C<CPAN.pm> addresses this problem by
10410 allowing the user to specify extra informations and recipes in YAML
10411 files to either
10412
10413 =over
10414
10415 =item
10416
10417 pass additional arguments to one of the four commands,
10418
10419 =item
10420
10421 set environment variables
10422
10423 =item
10424
10425 instantiate an Expect object that reads from the console, waits for
10426 some regular expressions and enters some answers
10427
10428 =item
10429
10430 temporarily override assorted C<CPAN.pm> configuration variables
10431
10432 =item
10433
10434 disable the installation of an object altogether
10435
10436 =back
10437
10438 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10439 distribution in the C<distroprefs/> directory for examples.
10440
10441 =head2 Filenames
10442
10443 The YAML files themselves must have the C<.yml> extension, all other
10444 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10445 Storable> below). The containing directory can be specified in
10446 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10447 prefs_dir> in the CPAN shell to set and activate the distroprefs
10448 system.
10449
10450 Every YAML file may contain arbitrary documents according to the YAML
10451 specification and every single document is treated as an entity that
10452 can specify the treatment of a single distribution.
10453
10454 The names of the files can be picked freely, C<CPAN.pm> always reads
10455 all files (in alphabetical order) and takes the key C<match> (see
10456 below in I<Language Specs>) as a hashref containing match criteria
10457 that determine if the current distribution matches the YAML document
10458 or not.
10459
10460 =head2 Fallback Data::Dumper and Storable
10461
10462 If neither your configured C<yaml_module> nor YAML.pm is installed
10463 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10464 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10465 directory. These files are expected to contain one or more hashrefs.
10466 For Data::Dumper generated files, this is expected to be done with by
10467 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10468 with the command
10469
10470     ysh < somefile.yml > somefile.dd
10471
10472 For Storable files the rule is that they must be constructed such that
10473 C<Storable::retrieve(file)> returns an array reference and the array
10474 elements represent one distropref object each. The conversion from
10475 YAML would look like so:
10476
10477     perl -MYAML=LoadFile -MStorable=nstore -e '
10478         @y=LoadFile(shift);
10479         nstore(\@y, shift)' somefile.yml somefile.st
10480
10481 In bootstrapping situations it is usually sufficient to translate only
10482 a few YAML files to Data::Dumper for the crucial modules like
10483 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10484 over Data::Dumper, remember to pull out a Storable version that writes
10485 an older format than all the other Storable versions that will need to
10486 read them.
10487
10488 =head2 Blueprint
10489
10490 The following example contains all supported keywords and structures
10491 with the exception of C<eexpect> which can be used instead of
10492 C<expect>.
10493
10494   ---
10495   comment: "Demo"
10496   match:
10497     module: "Dancing::Queen"
10498     distribution: "^CHACHACHA/Dancing-"
10499     perl: "/usr/local/cariba-perl/bin/perl"
10500     perlconfig:
10501       archname: "freebsd"
10502   disabled: 1
10503   cpanconfig:
10504     make: gmake
10505   pl:
10506     args:
10507       - "--somearg=specialcase"
10508
10509     env: {}
10510
10511     expect:
10512       - "Which is your favorite fruit"
10513       - "apple\n"
10514
10515   make:
10516     args:
10517       - all
10518       - extra-all
10519
10520     env: {}
10521
10522     expect: []
10523
10524     commendline: "echo SKIPPING make"
10525
10526   test:
10527     args: []
10528
10529     env: {}
10530
10531     expect: []
10532
10533   install:
10534     args: []
10535
10536     env:
10537       WANT_TO_INSTALL: YES
10538
10539     expect:
10540       - "Do you really want to install"
10541       - "y\n"
10542
10543   patches:
10544     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10545
10546
10547 =head2 Language Specs
10548
10549 Every YAML document represents a single hash reference. The valid keys
10550 in this hash are as follows:
10551
10552 =over
10553
10554 =item comment [scalar]
10555
10556 A comment
10557
10558 =item cpanconfig [hash]
10559
10560 Temporarily override assorted C<CPAN.pm> configuration variables.
10561
10562 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10563 C<make>, C<make_install_make_command>, C<prefer_installer>,
10564 C<test_report>. Please report as a bug when you need another one
10565 supported.
10566
10567 =item disabled [boolean]
10568
10569 Specifies that this distribution shall not be processed at all.
10570
10571 =item goto [string]
10572
10573 The canonical name of a delegate distribution that shall be installed
10574 instead. Useful when a new version, although it tests OK itself,
10575 breaks something else or a developer release or a fork is already
10576 uploaded that is better than the last released version.
10577
10578 =item install [hash]
10579
10580 Processing instructions for the C<make install> or C<./Build install>
10581 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10582
10583 =item make [hash]
10584
10585 Processing instructions for the C<make> or C<./Build> phase of the
10586 CPAN mantra. See below under I<Processiong Instructions>.
10587
10588 =item match [hash]
10589
10590 A hashref with one or more of the keys C<distribution>, C<modules>,
10591 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10592 specific CPAN distribution or installation.
10593
10594 The corresponding values are interpreted as regular expressions. The
10595 C<distribution> related one will be matched against the canonical
10596 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10597
10598 The C<module> related one will be matched against I<all> modules
10599 contained in the distribution until one module matches.
10600
10601 The C<perl> related one will be matched against C<$^X>.
10602
10603 The value associated with C<perlconfig> is itself a hashref that is
10604 matched against corresponding values in the C<%Config::Config> hash
10605 living in the C< Config.pm > module.
10606
10607 If more than one restriction of C<module>, C<distribution>, and
10608 C<perl> is specified, the results of the separately computed match
10609 values must all match. If this is the case then the hashref
10610 represented by the YAML document is returned as the preference
10611 structure for the current distribution.
10612
10613 =item patches [array]
10614
10615 An array of patches on CPAN or on the local disk to be applied in
10616 order via the external patch program. If the value for the C<-p>
10617 parameter is C<0> or C<1> is determined by reading the patch
10618 beforehand.
10619
10620 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10621 knows about it B<and> a patch is written by the C<makepatch> program,
10622 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10623 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10624 distribution.
10625
10626 =item pl [hash]
10627
10628 Processing instructions for the C<perl Makefile.PL> or C<perl
10629 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10630 Instructions>.
10631
10632 =item test [hash]
10633
10634 Processing instructions for the C<make test> or C<./Build test> phase
10635 of the CPAN mantra. See below under I<Processiong Instructions>.
10636
10637 =back
10638
10639 =head2 Processing Instructions
10640
10641 =over
10642
10643 =item args [array]
10644
10645 Arguments to be added to the command line
10646
10647 =item commandline
10648
10649 A full commandline that will be executed as it stands by a system
10650 call. During the execution the environment variable PERL will is set
10651 to $^X. If C<commandline> is specified, the content of C<args> is not
10652 used.
10653
10654 =item eexpect [hash]
10655
10656 Extended C<expect>. This is a hash reference with three allowed keys,
10657 C<mode>, C<timeout>, and C<talk>.
10658
10659 C<mode> may have the values C<deterministic> for the case where all
10660 questions come in the order written down and C<anyorder> for the case
10661 where the questions may come in any order. The default mode is
10662 C<deterministic>.
10663
10664 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10665 OK. In the case of a C<mode=deterministic> the timeout denotes the
10666 timeout per question, in the case of C<mode=anyorder> it denotes the
10667 timeout per byte received from the stream or questions.
10668
10669 C<talk> is a reference to an array that contains alternating questions
10670 and answers. Questions are regular expressions and answers are literal
10671 strings. The Expect module will then watch the stream coming from the
10672 execution of the external program (C<perl Makefile.PL>, C<perl
10673 Build.PL>, C<make>, etc.).
10674
10675 In the case of C<mode=deterministic> the CPAN.pm will inject the
10676 according answer as soon as the stream matches the regular expression.
10677 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10678 soon as the timeout is reached for the next byte in the input stream.
10679 In the latter case it removes the according question/answer pair from
10680 the array, so if you want to answer the question C<Do you really want
10681 to do that> several times, then it must be included in the array at
10682 least as often as you want this answer to be given.
10683
10684 =item env [hash]
10685
10686 Environment variables to be set during the command
10687
10688 =item expect [array]
10689
10690 C<< expect: <array> >> is a short notation for
10691
10692   eexpect:
10693     mode: deterministic
10694     timeout: 15
10695     talk: <array>
10696
10697 =back
10698
10699 =head2 Schema verification with C<Kwalify>
10700
10701 If you have the C<Kwalify> module installed (which is part of the
10702 Bundle::CPANxxl), then all your distroprefs files are checked for
10703 syntactical correctness.
10704
10705 =head2 Example Distroprefs Files
10706
10707 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10708 are really just examples and should not be used without care because
10709 they cannot fit everybody's purpose. After all the authors of the
10710 packages that ask questions had a need to ask, so you should watch
10711 their questions and adjust the examples to your environment and your
10712 needs. You have beend warned:-)
10713
10714 =head1 PROGRAMMER'S INTERFACE
10715
10716 If you do not enter the shell, the available shell commands are both
10717 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10718 functions in the calling package (C<install(...)>).  Before calling low-level
10719 commands it makes sense to initialize components of CPAN you need, e.g.:
10720
10721   CPAN::HandleConfig->load;
10722   CPAN::Shell::setup_output;
10723   CPAN::Index->reload;
10724
10725 High-level commands do such initializations automatically.
10726
10727 There's currently only one class that has a stable interface -
10728 CPAN::Shell. All commands that are available in the CPAN shell are
10729 methods of the class CPAN::Shell. Each of the commands that produce
10730 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10731 the IDs of all modules within the list.
10732
10733 =over 2
10734
10735 =item expand($type,@things)
10736
10737 The IDs of all objects available within a program are strings that can
10738 be expanded to the corresponding real objects with the
10739 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10740 list of CPAN::Module objects according to the C<@things> arguments
10741 given. In scalar context it only returns the first element of the
10742 list.
10743
10744 =item expandany(@things)
10745
10746 Like expand, but returns objects of the appropriate type, i.e.
10747 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10748 CPAN::Distribution objects for distributions. Note: it does not expand
10749 to CPAN::Author objects.
10750
10751 =item Programming Examples
10752
10753 This enables the programmer to do operations that combine
10754 functionalities that are available in the shell.
10755
10756     # install everything that is outdated on my disk:
10757     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10758
10759     # install my favorite programs if necessary:
10760     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10761         CPAN::Shell->install($mod);
10762     }
10763
10764     # list all modules on my disk that have no VERSION number
10765     for $mod (CPAN::Shell->expand("Module","/./")){
10766         next unless $mod->inst_file;
10767         # MakeMaker convention for undefined $VERSION:
10768         next unless $mod->inst_version eq "undef";
10769         print "No VERSION in ", $mod->id, "\n";
10770     }
10771
10772     # find out which distribution on CPAN contains a module:
10773     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10774
10775 Or if you want to write a cronjob to watch The CPAN, you could list
10776 all modules that need updating. First a quick and dirty way:
10777
10778     perl -e 'use CPAN; CPAN::Shell->r;'
10779
10780 If you don't want to get any output in the case that all modules are
10781 up to date, you can parse the output of above command for the regular
10782 expression //modules are up to date// and decide to mail the output
10783 only if it doesn't match. Ick?
10784
10785 If you prefer to do it more in a programmer style in one single
10786 process, maybe something like this suits you better:
10787
10788   # list all modules on my disk that have newer versions on CPAN
10789   for $mod (CPAN::Shell->expand("Module","/./")){
10790     next unless $mod->inst_file;
10791     next if $mod->uptodate;
10792     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10793         $mod->id, $mod->inst_version, $mod->cpan_version;
10794   }
10795
10796 If that gives you too much output every day, you maybe only want to
10797 watch for three modules. You can write
10798
10799   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10800
10801 as the first line instead. Or you can combine some of the above
10802 tricks:
10803
10804   # watch only for a new mod_perl module
10805   $mod = CPAN::Shell->expand("Module","mod_perl");
10806   exit if $mod->uptodate;
10807   # new mod_perl arrived, let me know all update recommendations
10808   CPAN::Shell->r;
10809
10810 =back
10811
10812 =head2 Methods in the other Classes
10813
10814 =over 4
10815
10816 =item CPAN::Author::as_glimpse()
10817
10818 Returns a one-line description of the author
10819
10820 =item CPAN::Author::as_string()
10821
10822 Returns a multi-line description of the author
10823
10824 =item CPAN::Author::email()
10825
10826 Returns the author's email address
10827
10828 =item CPAN::Author::fullname()
10829
10830 Returns the author's name
10831
10832 =item CPAN::Author::name()
10833
10834 An alias for fullname
10835
10836 =item CPAN::Bundle::as_glimpse()
10837
10838 Returns a one-line description of the bundle
10839
10840 =item CPAN::Bundle::as_string()
10841
10842 Returns a multi-line description of the bundle
10843
10844 =item CPAN::Bundle::clean()
10845
10846 Recursively runs the C<clean> method on all items contained in the bundle.
10847
10848 =item CPAN::Bundle::contains()
10849
10850 Returns a list of objects' IDs contained in a bundle. The associated
10851 objects may be bundles, modules or distributions.
10852
10853 =item CPAN::Bundle::force($method,@args)
10854
10855 Forces CPAN to perform a task that it normally would have refused to
10856 do. Force takes as arguments a method name to be called and any number
10857 of additional arguments that should be passed to the called method.
10858 The internals of the object get the needed changes so that CPAN.pm
10859 does not refuse to take the action. The C<force> is passed recursively
10860 to all contained objects. See also the section above on the C<force>
10861 and the C<fforce> pragma.
10862
10863 =item CPAN::Bundle::get()
10864
10865 Recursively runs the C<get> method on all items contained in the bundle
10866
10867 =item CPAN::Bundle::inst_file()
10868
10869 Returns the highest installed version of the bundle in either @INC or
10870 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10871 CPAN::Module::inst_file.
10872
10873 =item CPAN::Bundle::inst_version()
10874
10875 Like CPAN::Bundle::inst_file, but returns the $VERSION
10876
10877 =item CPAN::Bundle::uptodate()
10878
10879 Returns 1 if the bundle itself and all its members are uptodate.
10880
10881 =item CPAN::Bundle::install()
10882
10883 Recursively runs the C<install> method on all items contained in the bundle
10884
10885 =item CPAN::Bundle::make()
10886
10887 Recursively runs the C<make> method on all items contained in the bundle
10888
10889 =item CPAN::Bundle::readme()
10890
10891 Recursively runs the C<readme> method on all items contained in the bundle
10892
10893 =item CPAN::Bundle::test()
10894
10895 Recursively runs the C<test> method on all items contained in the bundle
10896
10897 =item CPAN::Distribution::as_glimpse()
10898
10899 Returns a one-line description of the distribution
10900
10901 =item CPAN::Distribution::as_string()
10902
10903 Returns a multi-line description of the distribution
10904
10905 =item CPAN::Distribution::author
10906
10907 Returns the CPAN::Author object of the maintainer who uploaded this
10908 distribution
10909
10910 =item CPAN::Distribution::clean()
10911
10912 Changes to the directory where the distribution has been unpacked and
10913 runs C<make clean> there.
10914
10915 =item CPAN::Distribution::containsmods()
10916
10917 Returns a list of IDs of modules contained in a distribution file.
10918 Only works for distributions listed in the 02packages.details.txt.gz
10919 file. This typically means that only the most recent version of a
10920 distribution is covered.
10921
10922 =item CPAN::Distribution::cvs_import()
10923
10924 Changes to the directory where the distribution has been unpacked and
10925 runs something like
10926
10927     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10928
10929 there.
10930
10931 =item CPAN::Distribution::dir()
10932
10933 Returns the directory into which this distribution has been unpacked.
10934
10935 =item CPAN::Distribution::force($method,@args)
10936
10937 Forces CPAN to perform a task that it normally would have refused to
10938 do. Force takes as arguments a method name to be called and any number
10939 of additional arguments that should be passed to the called method.
10940 The internals of the object get the needed changes so that CPAN.pm
10941 does not refuse to take the action. See also the section above on the
10942 C<force> and the C<fforce> pragma.
10943
10944 =item CPAN::Distribution::get()
10945
10946 Downloads the distribution from CPAN and unpacks it. Does nothing if
10947 the distribution has already been downloaded and unpacked within the
10948 current session.
10949
10950 =item CPAN::Distribution::install()
10951
10952 Changes to the directory where the distribution has been unpacked and
10953 runs the external command C<make install> there. If C<make> has not
10954 yet been run, it will be run first. A C<make test> will be issued in
10955 any case and if this fails, the install will be canceled. The
10956 cancellation can be avoided by letting C<force> run the C<install> for
10957 you.
10958
10959 This install method has only the power to install the distribution if
10960 there are no dependencies in the way. To install an object and all of
10961 its dependencies, use CPAN::Shell->install.
10962
10963 Note that install() gives no meaningful return value. See uptodate().
10964
10965 =item CPAN::Distribution::install_tested()
10966
10967 Install all the distributions that have been tested sucessfully but
10968 not yet installed. See also C<is_tested>.
10969
10970 =item CPAN::Distribution::isa_perl()
10971
10972 Returns 1 if this distribution file seems to be a perl distribution.
10973 Normally this is derived from the file name only, but the index from
10974 CPAN can contain a hint to achieve a return value of true for other
10975 filenames too.
10976
10977 =item CPAN::Distribution::is_tested()
10978
10979 List all the distributions that have been tested sucessfully but not
10980 yet installed. See also C<install_tested>.
10981
10982 =item CPAN::Distribution::look()
10983
10984 Changes to the directory where the distribution has been unpacked and
10985 opens a subshell there. Exiting the subshell returns.
10986
10987 =item CPAN::Distribution::make()
10988
10989 First runs the C<get> method to make sure the distribution is
10990 downloaded and unpacked. Changes to the directory where the
10991 distribution has been unpacked and runs the external commands C<perl
10992 Makefile.PL> or C<perl Build.PL> and C<make> there.
10993
10994 =item CPAN::Distribution::perldoc()
10995
10996 Downloads the pod documentation of the file associated with a
10997 distribution (in html format) and runs it through the external
10998 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10999 isn't available, it converts it to plain text with external
11000 command html2text and runs it through the pager specified
11001 in C<$CPAN::Config->{pager}>
11002
11003 =item CPAN::Distribution::prefs()
11004
11005 Returns the hash reference from the first matching YAML file that the
11006 user has deposited in the C<prefs_dir/> directory. The first
11007 succeeding match wins. The files in the C<prefs_dir/> are processed
11008 alphabetically and the canonical distroname (e.g.
11009 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11010 stored in the $root->{match}{distribution} attribute value.
11011 Additionally all module names contained in a distribution are matched
11012 agains the regular expressions in the $root->{match}{module} attribute
11013 value. The two match values are ANDed together. Each of the two
11014 attributes are optional.
11015
11016 =item CPAN::Distribution::prereq_pm()
11017
11018 Returns the hash reference that has been announced by a distribution
11019 as the the C<requires> and C<build_requires> elements. These can be
11020 declared either by the C<META.yml> (if authoritative) or can be
11021 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11022 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11023 a comment in the produced C<Makefile>. I<Note>: this method only works
11024 after an attempt has been made to C<make> the distribution. Returns
11025 undef otherwise.
11026
11027 =item CPAN::Distribution::readme()
11028
11029 Downloads the README file associated with a distribution and runs it
11030 through the pager specified in C<$CPAN::Config->{pager}>.
11031
11032 =item CPAN::Distribution::reports()
11033
11034 Downloads report data for this distribution from cpantesters.perl.org
11035 and displays a subset of them.
11036
11037 =item CPAN::Distribution::read_yaml()
11038
11039 Returns the content of the META.yml of this distro as a hashref. Note:
11040 works only after an attempt has been made to C<make> the distribution.
11041 Returns undef otherwise. Also returns undef if the content of META.yml
11042 is not authoritative. (The rules about what exactly makes the content
11043 authoritative are still in flux.)
11044
11045 =item CPAN::Distribution::test()
11046
11047 Changes to the directory where the distribution has been unpacked and
11048 runs C<make test> there.
11049
11050 =item CPAN::Distribution::uptodate()
11051
11052 Returns 1 if all the modules contained in the distribution are
11053 uptodate. Relies on containsmods.
11054
11055 =item CPAN::Index::force_reload()
11056
11057 Forces a reload of all indices.
11058
11059 =item CPAN::Index::reload()
11060
11061 Reloads all indices if they have not been read for more than
11062 C<$CPAN::Config->{index_expire}> days.
11063
11064 =item CPAN::InfoObj::dump()
11065
11066 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11067 inherit this method. It prints the data structure associated with an
11068 object. Useful for debugging. Note: the data structure is considered
11069 internal and thus subject to change without notice.
11070
11071 =item CPAN::Module::as_glimpse()
11072
11073 Returns a one-line description of the module in four columns: The
11074 first column contains the word C<Module>, the second column consists
11075 of one character: an equals sign if this module is already installed
11076 and uptodate, a less-than sign if this module is installed but can be
11077 upgraded, and a space if the module is not installed. The third column
11078 is the name of the module and the fourth column gives maintainer or
11079 distribution information.
11080
11081 =item CPAN::Module::as_string()
11082
11083 Returns a multi-line description of the module
11084
11085 =item CPAN::Module::clean()
11086
11087 Runs a clean on the distribution associated with this module.
11088
11089 =item CPAN::Module::cpan_file()
11090
11091 Returns the filename on CPAN that is associated with the module.
11092
11093 =item CPAN::Module::cpan_version()
11094
11095 Returns the latest version of this module available on CPAN.
11096
11097 =item CPAN::Module::cvs_import()
11098
11099 Runs a cvs_import on the distribution associated with this module.
11100
11101 =item CPAN::Module::description()
11102
11103 Returns a 44 character description of this module. Only available for
11104 modules listed in The Module List (CPAN/modules/00modlist.long.html
11105 or 00modlist.long.txt.gz)
11106
11107 =item CPAN::Module::distribution()
11108
11109 Returns the CPAN::Distribution object that contains the current
11110 version of this module.
11111
11112 =item CPAN::Module::dslip_status()
11113
11114 Returns a hash reference. The keys of the hash are the letters C<D>,
11115 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11116 language, interface and public licence respectively. The data for the
11117 DSLIP status are collected by pause.perl.org when authors register
11118 their namespaces. The values of the 5 hash elements are one-character
11119 words whose meaning is described in the table below. There are also 5
11120 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11121 verbose value of the 5 status variables.
11122
11123 Where the 'DSLIP' characters have the following meanings:
11124
11125   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11126     i   - Idea, listed to gain consensus or as a placeholder
11127     c   - under construction but pre-alpha (not yet released)
11128     a/b - Alpha/Beta testing
11129     R   - Released
11130     M   - Mature (no rigorous definition)
11131     S   - Standard, supplied with Perl 5
11132
11133   S - Support Level:
11134     m   - Mailing-list
11135     d   - Developer
11136     u   - Usenet newsgroup comp.lang.perl.modules
11137     n   - None known, try comp.lang.perl.modules
11138     a   - abandoned; volunteers welcome to take over maintainance
11139
11140   L - Language Used:
11141     p   - Perl-only, no compiler needed, should be platform independent
11142     c   - C and perl, a C compiler will be needed
11143     h   - Hybrid, written in perl with optional C code, no compiler needed
11144     +   - C++ and perl, a C++ compiler will be needed
11145     o   - perl and another language other than C or C++
11146
11147   I - Interface Style
11148     f   - plain Functions, no references used
11149     h   - hybrid, object and function interfaces available
11150     n   - no interface at all (huh?)
11151     r   - some use of unblessed References or ties
11152     O   - Object oriented using blessed references and/or inheritance
11153
11154   P - Public License
11155     p   - Standard-Perl: user may choose between GPL and Artistic
11156     g   - GPL: GNU General Public License
11157     l   - LGPL: "GNU Lesser General Public License" (previously known as
11158           "GNU Library General Public License")
11159     b   - BSD: The BSD License
11160     a   - Artistic license alone
11161     o   - open source: appoved by www.opensource.org
11162     d   - allows distribution without restrictions
11163     r   - restricted distribtion
11164     n   - no license at all
11165
11166 =item CPAN::Module::force($method,@args)
11167
11168 Forces CPAN to perform a task that it normally would have refused to
11169 do. Force takes as arguments a method name to be called and any number
11170 of additional arguments that should be passed to the called method.
11171 The internals of the object get the needed changes so that CPAN.pm
11172 does not refuse to take the action. See also the section above on the
11173 C<force> and the C<fforce> pragma.
11174
11175 =item CPAN::Module::get()
11176
11177 Runs a get on the distribution associated with this module.
11178
11179 =item CPAN::Module::inst_file()
11180
11181 Returns the filename of the module found in @INC. The first file found
11182 is reported just like perl itself stops searching @INC when it finds a
11183 module.
11184
11185 =item CPAN::Module::available_file()
11186
11187 Returns the filename of the module found in PERL5LIB or @INC. The
11188 first file found is reported. The advantage of this method over
11189 C<inst_file> is that modules that have been tested but not yet
11190 installed are included because PERL5LIB keeps track of tested modules.
11191
11192 =item CPAN::Module::inst_version()
11193
11194 Returns the version number of the installed module in readable format.
11195
11196 =item CPAN::Module::available_version()
11197
11198 Returns the version number of the available module in readable format.
11199
11200 =item CPAN::Module::install()
11201
11202 Runs an C<install> on the distribution associated with this module.
11203
11204 =item CPAN::Module::look()
11205
11206 Changes to the directory where the distribution associated with this
11207 module has been unpacked and opens a subshell there. Exiting the
11208 subshell returns.
11209
11210 =item CPAN::Module::make()
11211
11212 Runs a C<make> on the distribution associated with this module.
11213
11214 =item CPAN::Module::manpage_headline()
11215
11216 If module is installed, peeks into the module's manpage, reads the
11217 headline and returns it. Moreover, if the module has been downloaded
11218 within this session, does the equivalent on the downloaded module even
11219 if it is not installed.
11220
11221 =item CPAN::Module::perldoc()
11222
11223 Runs a C<perldoc> on this module.
11224
11225 =item CPAN::Module::readme()
11226
11227 Runs a C<readme> on the distribution associated with this module.
11228
11229 =item CPAN::Module::reports()
11230
11231 Calls the reports() method on the associated distribution object.
11232
11233 =item CPAN::Module::test()
11234
11235 Runs a C<test> on the distribution associated with this module.
11236
11237 =item CPAN::Module::uptodate()
11238
11239 Returns 1 if the module is installed and up-to-date.
11240
11241 =item CPAN::Module::userid()
11242
11243 Returns the author's ID of the module.
11244
11245 =back
11246
11247 =head2 Cache Manager
11248
11249 Currently the cache manager only keeps track of the build directory
11250 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11251 deletes complete directories below C<build_dir> as soon as the size of
11252 all directories there gets bigger than $CPAN::Config->{build_cache}
11253 (in MB). The contents of this cache may be used for later
11254 re-installations that you intend to do manually, but will never be
11255 trusted by CPAN itself. This is due to the fact that the user might
11256 use these directories for building modules on different architectures.
11257
11258 There is another directory ($CPAN::Config->{keep_source_where}) where
11259 the original distribution files are kept. This directory is not
11260 covered by the cache manager and must be controlled by the user. If
11261 you choose to have the same directory as build_dir and as
11262 keep_source_where directory, then your sources will be deleted with
11263 the same fifo mechanism.
11264
11265 =head2 Bundles
11266
11267 A bundle is just a perl module in the namespace Bundle:: that does not
11268 define any functions or methods. It usually only contains documentation.
11269
11270 It starts like a perl module with a package declaration and a $VERSION
11271 variable. After that the pod section looks like any other pod with the
11272 only difference being that I<one special pod section> exists starting with
11273 (verbatim):
11274
11275         =head1 CONTENTS
11276
11277 In this pod section each line obeys the format
11278
11279         Module_Name [Version_String] [- optional text]
11280
11281 The only required part is the first field, the name of a module
11282 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11283 of the line is optional. The comment part is delimited by a dash just
11284 as in the man page header.
11285
11286 The distribution of a bundle should follow the same convention as
11287 other distributions.
11288
11289 Bundles are treated specially in the CPAN package. If you say 'install
11290 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11291 the modules in the CONTENTS section of the pod. You can install your
11292 own Bundles locally by placing a conformant Bundle file somewhere into
11293 your @INC path. The autobundle() command which is available in the
11294 shell interface does that for you by including all currently installed
11295 modules in a snapshot bundle file.
11296
11297 =head1 PREREQUISITES
11298
11299 If you have a local mirror of CPAN and can access all files with
11300 "file:" URLs, then you only need a perl better than perl5.003 to run
11301 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11302 required for non-UNIX systems or if your nearest CPAN site is
11303 associated with a URL that is not C<ftp:>.
11304
11305 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11306 implemented for an external ftp command or for an external lynx
11307 command.
11308
11309 =head1 UTILITIES
11310
11311 =head2 Finding packages and VERSION
11312
11313 This module presumes that all packages on CPAN
11314
11315 =over 2
11316
11317 =item *
11318
11319 declare their $VERSION variable in an easy to parse manner. This
11320 prerequisite can hardly be relaxed because it consumes far too much
11321 memory to load all packages into the running program just to determine
11322 the $VERSION variable. Currently all programs that are dealing with
11323 version use something like this
11324
11325     perl -MExtUtils::MakeMaker -le \
11326         'print MM->parse_version(shift)' filename
11327
11328 If you are author of a package and wonder if your $VERSION can be
11329 parsed, please try the above method.
11330
11331 =item *
11332
11333 come as compressed or gzipped tarfiles or as zip files and contain a
11334 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11335 without much enthusiasm).
11336
11337 =back
11338
11339 =head2 Debugging
11340
11341 The debugging of this module is a bit complex, because we have
11342 interferences of the software producing the indices on CPAN, of the
11343 mirroring process on CPAN, of packaging, of configuration, of
11344 synchronicity, and of bugs within CPAN.pm.
11345
11346 For debugging the code of CPAN.pm itself in interactive mode some more
11347 or less useful debugging aid can be turned on for most packages within
11348 CPAN.pm with one of
11349
11350 =over 2
11351
11352 =item o debug package...
11353
11354 sets debug mode for packages.
11355
11356 =item o debug -package...
11357
11358 unsets debug mode for packages.
11359
11360 =item o debug all
11361
11362 turns debugging on for all packages.
11363
11364 =item o debug number
11365
11366 =back
11367
11368 which sets the debugging packages directly. Note that C<o debug 0>
11369 turns debugging off.
11370
11371 What seems quite a successful strategy is the combination of C<reload
11372 cpan> and the debugging switches. Add a new debug statement while
11373 running in the shell and then issue a C<reload cpan> and see the new
11374 debugging messages immediately without losing the current context.
11375
11376 C<o debug> without an argument lists the valid package names and the
11377 current set of packages in debugging mode. C<o debug> has built-in
11378 completion support.
11379
11380 For debugging of CPAN data there is the C<dump> command which takes
11381 the same arguments as make/test/install and outputs each object's
11382 Data::Dumper dump. If an argument looks like a perl variable and
11383 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11384 Data::Dumper directly.
11385
11386 =head2 Floppy, Zip, Offline Mode
11387
11388 CPAN.pm works nicely without network too. If you maintain machines
11389 that are not networked at all, you should consider working with file:
11390 URLs. Of course, you have to collect your modules somewhere first. So
11391 you might use CPAN.pm to put together all you need on a networked
11392 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11393 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11394 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11395 with this floppy. See also below the paragraph about CD-ROM support.
11396
11397 =head2 Basic Utilities for Programmers
11398
11399 =over 2
11400
11401 =item has_inst($module)
11402
11403 Returns true if the module is installed. Used to load all modules into
11404 the running CPAN.pm which are considered optional. The config variable
11405 C<dontload_list> can be used to intercept the C<has_inst()> call such
11406 that an optional module is not loaded despite being available. For
11407 example the following command will prevent that C<YAML.pm> is being
11408 loaded:
11409
11410     cpan> o conf dontload_list push YAML
11411
11412 See the source for details.
11413
11414 =item has_usable($module)
11415
11416 Returns true if the module is installed and is in a usable state. Only
11417 useful for a handful of modules that are used internally. See the
11418 source for details.
11419
11420 =item instance($module)
11421
11422 The constructor for all the singletons used to represent modules,
11423 distributions, authors and bundles. If the object already exists, this
11424 method returns the object, otherwise it calls the constructor.
11425
11426 =back
11427
11428 =head1 SECURITY
11429
11430 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11431 install foreign, unmasked, unsigned code on your machine. We compare
11432 to a checksum that comes from the net just as the distribution file
11433 itself. But we try to make it easy to add security on demand:
11434
11435 =head2 Cryptographically signed modules
11436
11437 Since release 1.77 CPAN.pm has been able to verify cryptographically
11438 signed module distributions using Module::Signature.  The CPAN modules
11439 can be signed by their authors, thus giving more security.  The simple
11440 unsigned MD5 checksums that were used before by CPAN protect mainly
11441 against accidental file corruption.
11442
11443 You will need to have Module::Signature installed, which in turn
11444 requires that you have at least one of Crypt::OpenPGP module or the
11445 command-line F<gpg> tool installed.
11446
11447 You will also need to be able to connect over the Internet to the public
11448 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11449
11450 The configuration parameter check_sigs is there to turn signature
11451 checking on or off.
11452
11453 =head1 EXPORT
11454
11455 Most functions in package CPAN are exported per default. The reason
11456 for this is that the primary use is intended for the cpan shell or for
11457 one-liners.
11458
11459 =head1 ENVIRONMENT
11460
11461 When the CPAN shell enters a subshell via the look command, it sets
11462 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11463 already set.
11464
11465 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11466
11467 When the config variable ftp_passive is set, all downloads will be run
11468 with the environment variable FTP_PASSIVE set to this value. This is
11469 in general a good idea as it influences both Net::FTP and LWP based
11470 connections. The same effect can be achieved by starting the cpan
11471 shell with this environment variable set. For Net::FTP alone, one can
11472 also always set passive mode by running libnetcfg.
11473
11474 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11475
11476 Populating a freshly installed perl with my favorite modules is pretty
11477 easy if you maintain a private bundle definition file. To get a useful
11478 blueprint of a bundle definition file, the command autobundle can be used
11479 on the CPAN shell command line. This command writes a bundle definition
11480 file for all modules that are installed for the currently running perl
11481 interpreter. It's recommended to run this command only once and from then
11482 on maintain the file manually under a private name, say
11483 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11484
11485     cpan> install Bundle::my_bundle
11486
11487 then answer a few questions and then go out for a coffee.
11488
11489 Maintaining a bundle definition file means keeping track of two
11490 things: dependencies and interactivity. CPAN.pm sometimes fails on
11491 calculating dependencies because not all modules define all MakeMaker
11492 attributes correctly, so a bundle definition file should specify
11493 prerequisites as early as possible. On the other hand, it's a bit
11494 annoying that many distributions need some interactive configuring. So
11495 what I try to accomplish in my private bundle file is to have the
11496 packages that need to be configured early in the file and the gentle
11497 ones later, so I can go out after a few minutes and leave CPAN.pm
11498 untended.
11499
11500 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11501
11502 Thanks to Graham Barr for contributing the following paragraphs about
11503 the interaction between perl, and various firewall configurations. For
11504 further information on firewalls, it is recommended to consult the
11505 documentation that comes with the ncftp program. If you are unable to
11506 go through the firewall with a simple Perl setup, it is very likely
11507 that you can configure ncftp so that it works for your firewall.
11508
11509 =head2 Three basic types of firewalls
11510
11511 Firewalls can be categorized into three basic types.
11512
11513 =over 4
11514
11515 =item http firewall
11516
11517 This is where the firewall machine runs a web server and to access the
11518 outside world you must do it via the web server. If you set environment
11519 variables like http_proxy or ftp_proxy to a values beginning with http://
11520 or in your web browser you have to set proxy information then you know
11521 you are running an http firewall.
11522
11523 To access servers outside these types of firewalls with perl (even for
11524 ftp) you will need to use LWP.
11525
11526 =item ftp firewall
11527
11528 This where the firewall machine runs an ftp server. This kind of
11529 firewall will only let you access ftp servers outside the firewall.
11530 This is usually done by connecting to the firewall with ftp, then
11531 entering a username like "user@outside.host.com"
11532
11533 To access servers outside these type of firewalls with perl you
11534 will need to use Net::FTP.
11535
11536 =item One way visibility
11537
11538 I say one way visibility as these firewalls try to make themselves look
11539 invisible to the users inside the firewall. An FTP data connection is
11540 normally created by sending the remote server your IP address and then
11541 listening for the connection. But the remote server will not be able to
11542 connect to you because of the firewall. So for these types of firewall
11543 FTP connections need to be done in a passive mode.
11544
11545 There are two that I can think off.
11546
11547 =over 4
11548
11549 =item SOCKS
11550
11551 If you are using a SOCKS firewall you will need to compile perl and link
11552 it with the SOCKS library, this is what is normally called a 'socksified'
11553 perl. With this executable you will be able to connect to servers outside
11554 the firewall as if it is not there.
11555
11556 =item IP Masquerade
11557
11558 This is the firewall implemented in the Linux kernel, it allows you to
11559 hide a complete network behind one IP address. With this firewall no
11560 special compiling is needed as you can access hosts directly.
11561
11562 For accessing ftp servers behind such firewalls you usually need to
11563 set the environment variable C<FTP_PASSIVE> or the config variable
11564 ftp_passive to a true value.
11565
11566 =back
11567
11568 =back
11569
11570 =head2 Configuring lynx or ncftp for going through a firewall
11571
11572 If you can go through your firewall with e.g. lynx, presumably with a
11573 command such as
11574
11575     /usr/local/bin/lynx -pscott:tiger
11576
11577 then you would configure CPAN.pm with the command
11578
11579     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11580
11581 That's all. Similarly for ncftp or ftp, you would configure something
11582 like
11583
11584     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11585
11586 Your mileage may vary...
11587
11588 =head1 FAQ
11589
11590 =over 4
11591
11592 =item 1)
11593
11594 I installed a new version of module X but CPAN keeps saying,
11595 I have the old version installed
11596
11597 Most probably you B<do> have the old version installed. This can
11598 happen if a module installs itself into a different directory in the
11599 @INC path than it was previously installed. This is not really a
11600 CPAN.pm problem, you would have the same problem when installing the
11601 module manually. The easiest way to prevent this behaviour is to add
11602 the argument C<UNINST=1> to the C<make install> call, and that is why
11603 many people add this argument permanently by configuring
11604
11605   o conf make_install_arg UNINST=1
11606
11607 =item 2)
11608
11609 So why is UNINST=1 not the default?
11610
11611 Because there are people who have their precise expectations about who
11612 may install where in the @INC path and who uses which @INC array. In
11613 fine tuned environments C<UNINST=1> can cause damage.
11614
11615 =item 3)
11616
11617 I want to clean up my mess, and install a new perl along with
11618 all modules I have. How do I go about it?
11619
11620 Run the autobundle command for your old perl and optionally rename the
11621 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11622 with the Configure option prefix, e.g.
11623
11624     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11625
11626 Install the bundle file you produced in the first step with something like
11627
11628     cpan> install Bundle::mybundle
11629
11630 and you're done.
11631
11632 =item 4)
11633
11634 When I install bundles or multiple modules with one command
11635 there is too much output to keep track of.
11636
11637 You may want to configure something like
11638
11639   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11640   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11641
11642 so that STDOUT is captured in a file for later inspection.
11643
11644
11645 =item 5)
11646
11647 I am not root, how can I install a module in a personal directory?
11648
11649 First of all, you will want to use your own configuration, not the one
11650 that your root user installed. If you do not have permission to write
11651 in the cpan directory that root has configured, you will be asked if
11652 you want to create your own config. Answering "yes" will bring you into
11653 CPAN's configuration stage, using the system config for all defaults except
11654 things that have to do with CPAN's work directory, saving your choices to
11655 your MyConfig.pm file.
11656
11657 You can also manually initiate this process with the following command:
11658
11659     % perl -MCPAN -e 'mkmyconfig'
11660
11661 or by running
11662
11663     mkmyconfig
11664
11665 from the CPAN shell.
11666
11667 You will most probably also want to configure something like this:
11668
11669   o conf makepl_arg "LIB=~/myperl/lib \
11670                     INSTALLMAN1DIR=~/myperl/man/man1 \
11671                     INSTALLMAN3DIR=~/myperl/man/man3 \
11672                     INSTALLSCRIPT=~/myperl/bin \
11673                     INSTALLBIN=~/myperl/bin"
11674
11675 and then (oh joy) the equivalent command for Module::Build.
11676
11677 You can make this setting permanent like all C<o conf> settings with
11678 C<o conf commit> or by setting C<auto_commit> beforehand.
11679
11680 You will have to add ~/myperl/man to the MANPATH environment variable
11681 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11682 including
11683
11684   use lib "$ENV{HOME}/myperl/lib";
11685
11686 or setting the PERL5LIB environment variable.
11687
11688 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11689 that for Windows we use the File::HomeDir module that provides an
11690 equivalent to the concept of the home directory on Unix.
11691
11692 Another thing you should bear in mind is that the UNINST parameter can
11693 be dnagerous when you are installing into a private area because you
11694 might accidentally remove modules that other people depend on that are
11695 not using the private area.
11696
11697 =item 6)
11698
11699 How to get a package, unwrap it, and make a change before building it?
11700
11701 Have a look at the C<look> (!) command.
11702
11703 =item 7)
11704
11705 I installed a Bundle and had a couple of fails. When I
11706 retried, everything resolved nicely. Can this be fixed to work
11707 on first try?
11708
11709 The reason for this is that CPAN does not know the dependencies of all
11710 modules when it starts out. To decide about the additional items to
11711 install, it just uses data found in the META.yml file or the generated
11712 Makefile. An undetected missing piece breaks the process. But it may
11713 well be that your Bundle installs some prerequisite later than some
11714 depending item and thus your second try is able to resolve everything.
11715 Please note, CPAN.pm does not know the dependency tree in advance and
11716 cannot sort the queue of things to install in a topologically correct
11717 order. It resolves perfectly well IF all modules declare the
11718 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11719 the C<requires> stanza of Module::Build. For bundles which fail and
11720 you need to install often, it is recommended to sort the Bundle
11721 definition file manually.
11722
11723 =item 8)
11724
11725 In our intranet we have many modules for internal use. How
11726 can I integrate these modules with CPAN.pm but without uploading
11727 the modules to CPAN?
11728
11729 Have a look at the CPAN::Site module.
11730
11731 =item 9)
11732
11733 When I run CPAN's shell, I get an error message about things in my
11734 /etc/inputrc (or ~/.inputrc) file.
11735
11736 These are readline issues and can only be fixed by studying readline
11737 configuration on your architecture and adjusting the referenced file
11738 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11739 and edit them. Quite often harmless changes like uppercasing or
11740 lowercasing some arguments solves the problem.
11741
11742 =item 10)
11743
11744 Some authors have strange characters in their names.
11745
11746 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11747 expecting ISO-8859-1 charset, a converter can be activated by setting
11748 term_is_latin to a true value in your config file. One way of doing so
11749 would be
11750
11751     cpan> o conf term_is_latin 1
11752
11753 If other charset support is needed, please file a bugreport against
11754 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11755 the support or maybe UTF-8 terminals become widely available.
11756
11757 =item 11)
11758
11759 When an install fails for some reason and then I correct the error
11760 condition and retry, CPAN.pm refuses to install the module, saying
11761 C<Already tried without success>.
11762
11763 Use the force pragma like so
11764
11765   force install Foo::Bar
11766
11767 Or you can use
11768
11769   look Foo::Bar
11770
11771 and then 'make install' directly in the subshell.
11772
11773 =item 12)
11774
11775 How do I install a "DEVELOPER RELEASE" of a module?
11776
11777 By default, CPAN will install the latest non-developer release of a
11778 module. If you want to install a dev release, you have to specify the
11779 partial path starting with the author id to the tarball you wish to
11780 install, like so:
11781
11782     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11783
11784 Note that you can use the C<ls> command to get this path listed.
11785
11786 =item 13)
11787
11788 How do I install a module and all its dependencies from the commandline,
11789 without being prompted for anything, despite my CPAN configuration
11790 (or lack thereof)?
11791
11792 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11793 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11794 asked any questions at all (assuming the modules you are installing are
11795 nice about obeying that variable as well):
11796
11797     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11798
11799 =item 14)
11800
11801 How do I create a Module::Build based Build.PL derived from an
11802 ExtUtils::MakeMaker focused Makefile.PL?
11803
11804 http://search.cpan.org/search?query=Module::Build::Convert
11805
11806 http://www.refcnt.org/papers/module-build-convert
11807
11808 =item 15)
11809
11810 What's the best CPAN site for me?
11811
11812 The urllist config parameter is yours. You can add and remove sites at
11813 will. You should find out which sites have the best uptodateness,
11814 bandwidth, reliability, etc. and are topologically close to you. Some
11815 people prefer fast downloads, others uptodateness, others reliability.
11816 You decide which to try in which order.
11817
11818 Henk P. Penning maintains a site that collects data about CPAN sites:
11819
11820   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11821
11822 =back
11823
11824 =head1 COMPATIBILITY
11825
11826 =head2 OLD PERL VERSIONS
11827
11828 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11829 newer versions. It is getting more and more difficult to get the
11830 minimal prerequisites working on older perls. It is close to
11831 impossible to get the whole Bundle::CPAN working there. If you're in
11832 the position to have only these old versions, be advised that CPAN is
11833 designed to work fine without the Bundle::CPAN installed.
11834
11835 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11836 compatible with ancient perls and that File::Temp is listed as a
11837 prerequisite but CPAN has reasonable workarounds if it is missing.
11838
11839 =head2 CPANPLUS
11840
11841 This module and its competitor, the CPANPLUS module, are both much
11842 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11843 more modular but it was never tried to make it compatible with CPAN.pm.
11844
11845 =head1 SECURITY ADVICE
11846
11847 This software enables you to upgrade software on your computer and so
11848 is inherently dangerous because the newly installed software may
11849 contain bugs and may alter the way your computer works or even make it
11850 unusable. Please consider backing up your data before every upgrade.
11851
11852 =head1 BUGS
11853
11854 Please report bugs via http://rt.cpan.org/
11855
11856 Before submitting a bug, please make sure that the traditional method
11857 of building a Perl module package from a shell by following the
11858 installation instructions of that package still works in your
11859 environment.
11860
11861 =head1 AUTHOR
11862
11863 Andreas Koenig C<< <andk@cpan.org> >>
11864
11865 =head1 LICENSE
11866
11867 This program is free software; you can redistribute it and/or
11868 modify it under the same terms as Perl itself.
11869
11870 See L<http://www.perl.com/perl/misc/Artistic.html>
11871
11872 =head1 TRANSLATIONS
11873
11874 Kawai,Takanori provides a Japanese translation of this manpage at
11875 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11876
11877 =head1 SEE ALSO
11878
11879 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11880
11881 =cut
11882
11883