lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.9101';
   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                                   dir      => File::Spec->tmpdir,
2842                                   template => 'cpan_install_XXXX',
2843                                   suffix   => '.txt',
2844                                   unlink   => 0,
2845                                  );
2846         }
2847         unless ( $installation_report_fh ) {
2848             warn("Couldn't open installation report file; " .
2849                  "no report file will be generated."
2850                 ) unless $previously_noticed++;
2851         }
2852     }
2853 }
2854
2855
2856 # The only reason for this method is currently to have a reliable
2857 # debugging utility that reveals which output is going through which
2858 # channel. No, I don't like the colors ;-)
2859
2860 # to turn colordebugging on, write
2861 # cpan> o conf colorize_output 1
2862
2863 #-> sub CPAN::Shell::print_ornamented ;
2864 {
2865     my $print_ornamented_have_warned = 0;
2866     sub colorize_output {
2867         my $colorize_output = $CPAN::Config->{colorize_output};
2868         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2869             unless ($print_ornamented_have_warned++) {
2870                 # no myprint/mywarn within myprint/mywarn!
2871                 warn "Colorize_output is set to true but Term::ANSIColor is not
2872 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2873             }
2874             $colorize_output = 0;
2875         }
2876         return $colorize_output;
2877     }
2878 }
2879
2880
2881 #-> sub CPAN::Shell::print_ornamented ;
2882 sub print_ornamented {
2883     my($self,$what,$ornament) = @_;
2884     return unless defined $what;
2885
2886     local $| = 1; # Flush immediately
2887     if ( $CPAN::Be_Silent ) {
2888         print {report_fh()} $what;
2889         return;
2890     }
2891     my $swhat = "$what"; # stringify if it is an object
2892     if ($CPAN::Config->{term_is_latin}){
2893         # courtesy jhi:
2894         $swhat
2895             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2896     }
2897     if ($self->colorize_output) {
2898         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2899             # if you want to have this configurable, please file a bugreport
2900             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2901         }
2902         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2903         if ($@) {
2904             print "Term::ANSIColor rejects color[$ornament]: $@\n
2905 Please choose a different color (Hint: try 'o conf init /color/')\n";
2906         }
2907         print $color_on,
2908             $swhat,
2909                 Term::ANSIColor::color("reset");
2910     } else {
2911         print $swhat;
2912     }
2913 }
2914
2915 #-> sub CPAN::Shell::myprint ;
2916
2917 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2918 # where to use what! I think, we send everything to STDOUT and use
2919 # print for normal/good news and warn for news that need more
2920 # attention. Yes, this is our working contract for now.
2921 sub myprint {
2922     my($self,$what) = @_;
2923
2924     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2925 }
2926
2927 #-> sub CPAN::Shell::myexit ;
2928 sub myexit {
2929     my($self,$what) = @_;
2930     $self->myprint($what);
2931     exit;
2932 }
2933
2934 #-> sub CPAN::Shell::mywarn ;
2935 sub mywarn {
2936     my($self,$what) = @_;
2937     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2938 }
2939
2940 # only to be used for shell commands
2941 #-> sub CPAN::Shell::mydie ;
2942 sub mydie {
2943     my($self,$what) = @_;
2944     $self->mywarn($what);
2945
2946     # If it is the shell, we want the following die to be silent,
2947     # but if it is not the shell, we would need a 'die $what'. We need
2948     # to take care that only shell commands use mydie. Is this
2949     # possible?
2950
2951     die "\n";
2952 }
2953
2954 # sub CPAN::Shell::colorable_makemaker_prompt ;
2955 sub colorable_makemaker_prompt {
2956     my($foo,$bar) = @_;
2957     if (CPAN::Shell->colorize_output) {
2958         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2959         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2960         print $color_on;
2961     }
2962     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2963     if (CPAN::Shell->colorize_output) {
2964         print Term::ANSIColor::color('reset');
2965     }
2966     return $ans;
2967 }
2968
2969 # use this only for unrecoverable errors!
2970 #-> sub CPAN::Shell::unrecoverable_error ;
2971 sub unrecoverable_error {
2972     my($self,$what) = @_;
2973     my @lines = split /\n/, $what;
2974     my $longest = 0;
2975     for my $l (@lines) {
2976         $longest = length $l if length $l > $longest;
2977     }
2978     $longest = 62 if $longest > 62;
2979     for my $l (@lines) {
2980         if ($l =~ /^\s*$/){
2981             $l = "\n";
2982             next;
2983         }
2984         $l = "==> $l";
2985         if (length $l < 66) {
2986             $l = pack "A66 A*", $l, "<==";
2987         }
2988         $l .= "\n";
2989     }
2990     unshift @lines, "\n";
2991     $self->mydie(join "", @lines);
2992 }
2993
2994 #-> sub CPAN::Shell::mysleep ;
2995 sub mysleep {
2996     my($self, $sleep) = @_;
2997     if (CPAN->has_inst("Time::HiRes")) {
2998         Time::HiRes::sleep($sleep);
2999     } else {
3000         sleep($sleep < 1 ? 1 : int($sleep + 0.5));
3001     }
3002 }
3003
3004 #-> sub CPAN::Shell::setup_output ;
3005 sub setup_output {
3006     return if -t STDOUT;
3007     my $odef = select STDERR;
3008     $| = 1;
3009     select STDOUT;
3010     $| = 1;
3011     select $odef;
3012 }
3013
3014 #-> sub CPAN::Shell::rematein ;
3015 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3016 sub rematein {
3017     my $self = shift;
3018     my($meth,@some) = @_;
3019     my @pragma;
3020     while($meth =~ /^(ff?orce|notest)$/) {
3021         push @pragma, $meth;
3022         $meth = shift @some or
3023             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3024                                    "cannot continue");
3025     }
3026     setup_output();
3027     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3028
3029     # Here is the place to set "test_count" on all involved parties to
3030     # 0. We then can pass this counter on to the involved
3031     # distributions and those can refuse to test if test_count > X. In
3032     # the first stab at it we could use a 1 for "X".
3033
3034     # But when do I reset the distributions to start with 0 again?
3035     # Jost suggested to have a random or cycling interaction ID that
3036     # we pass through. But the ID is something that is just left lying
3037     # around in addition to the counter, so I'd prefer to set the
3038     # counter to 0 now, and repeat at the end of the loop. But what
3039     # about dependencies? They appear later and are not reset, they
3040     # enter the queue but not its copy. How do they get a sensible
3041     # test_count?
3042
3043     my $needs_recursion_protection = "make|test|install";
3044
3045     # construct the queue
3046     my($s,@s,@qcopy);
3047   STHING: foreach $s (@some) {
3048         my $obj;
3049         if (ref $s) {
3050             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3051             $obj = $s;
3052         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3053         } elsif ($s =~ m|^/|) { # looks like a regexp
3054             if (substr($s,-1,1) eq ".") {
3055                 $obj = CPAN::Shell->expandany($s);
3056             } else {
3057                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3058                                         "not supported.\nRejecting argument '$s'\n");
3059                 $CPAN::Frontend->mysleep(2);
3060                 next;
3061             }
3062         } elsif ($meth eq "ls") {
3063             $self->globls($s,\@pragma);
3064             next STHING;
3065         } else {
3066             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3067             $obj = CPAN::Shell->expandany($s);
3068         }
3069         if (0) {
3070         } elsif (ref $obj) {
3071             if ($meth =~ /^($needs_recursion_protection)$/) {
3072                 # it would be silly to check for recursion for look or dump
3073                 # (we are in CPAN::Shell::rematein)
3074                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3075                 eval {  $obj->color_cmd_tmps(0,1); };
3076                 if ($@){
3077                     if (ref $@
3078                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3079                         $CPAN::Frontend->mywarn($@);
3080                     } else {
3081                         if (0) {
3082                             require Carp;
3083                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3084                         }
3085                         die;
3086                     }
3087                 }
3088             }
3089             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
3090             push @qcopy, $obj;
3091         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3092             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3093             if ($meth =~ /^(dump|ls|reports)$/) {
3094                 $obj->$meth();
3095             } else {
3096                 $CPAN::Frontend->mywarn(
3097                                         join "",
3098                                         "Don't be silly, you can't $meth ",
3099                                         $obj->fullname,
3100                                         " ;-)\n"
3101                                        );
3102                 $CPAN::Frontend->mysleep(2);
3103             }
3104         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3105             CPAN::InfoObj->dump($s);
3106         } else {
3107             $CPAN::Frontend
3108                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3109                           qq{don't know what it is.
3110 Try the command
3111
3112     i /$s/
3113
3114 to find objects with matching identifiers.
3115 });
3116             $CPAN::Frontend->mysleep(2);
3117         }
3118     }
3119
3120     # queuerunner (please be warned: when I started to change the
3121     # queue to hold objects instead of names, I made one or two
3122     # mistakes and never found which. I reverted back instead)
3123     while (my $q = CPAN::Queue->first) {
3124         my $obj;
3125         my $s = $q->as_string;
3126         my $reqtype = $q->reqtype || "";
3127         $obj = CPAN::Shell->expandany($s);
3128         unless ($obj) {
3129             # don't know how this can happen, maybe we should panic,
3130             # but maybe we get a solution from the first user who hits
3131             # this unfortunate exception?
3132             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3133                                     "to an object. Skipping.\n");
3134             $CPAN::Frontend->mysleep(5);
3135             CPAN::Queue->delete_first($s);
3136             next;
3137         }
3138         $obj->{reqtype} ||= "";
3139         {
3140             # force debugging because CPAN::SQLite somehow delivers us
3141             # an empty object;
3142
3143             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3144
3145             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3146                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3147         }
3148         if ($obj->{reqtype}) {
3149             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3150                 $obj->{reqtype} = $reqtype;
3151                 if (
3152                     exists $obj->{install}
3153                     &&
3154                     (
3155                      UNIVERSAL::can($obj->{install},"failed") ?
3156                      $obj->{install}->failed :
3157                      $obj->{install} =~ /^NO/
3158                     )
3159                    ) {
3160                     delete $obj->{install};
3161                     $CPAN::Frontend->mywarn
3162                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3163                 }
3164             }
3165         } else {
3166             $obj->{reqtype} = $reqtype;
3167         }
3168
3169         for my $pragma (@pragma) {
3170             if ($pragma
3171                 &&
3172                 $obj->can($pragma)){
3173                 $obj->$pragma($meth);
3174             }
3175         }
3176         if (UNIVERSAL::can($obj, 'called_for')) {
3177             $obj->called_for($s);
3178         }
3179         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3180                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3181
3182         push @qcopy, $obj;
3183         if (! UNIVERSAL::can($obj,$meth)) {
3184             # Must never happen
3185             my $serialized = "";
3186             if (0) {
3187             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3188                 $serialized = YAML::Syck::Dump($obj);
3189             } elsif ($CPAN::META->has_inst("YAML")) {
3190                 $serialized = YAML::Dump($obj);
3191             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3192                 $serialized = Data::Dumper::Dumper($obj);
3193             } else {
3194                 require overload;
3195                 $serialized = overload::StrVal($obj);
3196             }
3197             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3198             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3199         } elsif ($obj->$meth()){
3200             CPAN::Queue->delete($s);
3201             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3202         } else {
3203             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3204         }
3205
3206         $obj->undelay;
3207         for my $pragma (@pragma) {
3208             my $unpragma = "un$pragma";
3209             if ($obj->can($unpragma)) {
3210                 $obj->$unpragma();
3211             }
3212         }
3213         CPAN::Queue->delete_first($s);
3214     }
3215     if ($meth =~ /^($needs_recursion_protection)$/) {
3216         for my $obj (@qcopy) {
3217             $obj->color_cmd_tmps(0,0);
3218         }
3219     }
3220 }
3221
3222 #-> sub CPAN::Shell::recent ;
3223 sub recent {
3224   my($self) = @_;
3225
3226   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3227   return;
3228 }
3229
3230 {
3231     # set up the dispatching methods
3232     no strict "refs";
3233     for my $command (qw(
3234                         clean
3235                         cvs_import
3236                         dump
3237                         force
3238                         fforce
3239                         get
3240                         install
3241                         look
3242                         ls
3243                         make
3244                         notest
3245                         perldoc
3246                         readme
3247                         reports
3248                         test
3249                        )) {
3250         *$command = sub { shift->rematein($command, @_); };
3251     }
3252 }
3253
3254 package CPAN::LWP::UserAgent;
3255 use strict;
3256
3257 sub config {
3258     return if $SETUPDONE;
3259     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3260         require LWP::UserAgent;
3261         @ISA = qw(Exporter LWP::UserAgent);
3262         $SETUPDONE++;
3263     } else {
3264         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3265     }
3266 }
3267
3268 sub get_basic_credentials {
3269     my($self, $realm, $uri, $proxy) = @_;
3270     if ($USER && $PASSWD) {
3271         return ($USER, $PASSWD);
3272     }
3273     if ( $proxy ) {
3274         ($USER,$PASSWD) = $self->get_proxy_credentials();
3275     } else {
3276         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3277     }
3278     return($USER,$PASSWD);
3279 }
3280
3281 sub get_proxy_credentials {
3282     my $self = shift;
3283     my ($user, $password);
3284     if ( defined $CPAN::Config->{proxy_user} &&
3285          defined $CPAN::Config->{proxy_pass}) {
3286         $user = $CPAN::Config->{proxy_user};
3287         $password = $CPAN::Config->{proxy_pass};
3288         return ($user, $password);
3289     }
3290     my $username_prompt = "\nProxy authentication needed!
3291  (Note: to permanently configure username and password run
3292    o conf proxy_user your_username
3293    o conf proxy_pass your_password
3294      )\nUsername:";
3295     ($user, $password) =
3296         _get_username_and_password_from_user($username_prompt);
3297     return ($user,$password);
3298 }
3299
3300 sub get_non_proxy_credentials {
3301     my $self = shift;
3302     my ($user,$password);
3303     if ( defined $CPAN::Config->{username} &&
3304          defined $CPAN::Config->{password}) {
3305         $user = $CPAN::Config->{username};
3306         $password = $CPAN::Config->{password};
3307         return ($user, $password);
3308     }
3309     my $username_prompt = "\nAuthentication needed!
3310      (Note: to permanently configure username and password run
3311        o conf username your_username
3312        o conf password your_password
3313      )\nUsername:";
3314
3315     ($user, $password) =
3316         _get_username_and_password_from_user($username_prompt);
3317     return ($user,$password);
3318 }
3319
3320 sub _get_username_and_password_from_user {
3321     my $username_message = shift;
3322     my ($username,$password);
3323
3324     ExtUtils::MakeMaker->import(qw(prompt));
3325     $username = prompt($username_message);
3326         if ($CPAN::META->has_inst("Term::ReadKey")) {
3327             Term::ReadKey::ReadMode("noecho");
3328         }
3329     else {
3330         $CPAN::Frontend->mywarn(
3331             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3332         );
3333     }
3334     $password = prompt("Password:");
3335
3336         if ($CPAN::META->has_inst("Term::ReadKey")) {
3337             Term::ReadKey::ReadMode("restore");
3338         }
3339         $CPAN::Frontend->myprint("\n\n");
3340     return ($username,$password);
3341 }
3342
3343 # mirror(): Its purpose is to deal with proxy authentication. When we
3344 # call SUPER::mirror, we relly call the mirror method in
3345 # LWP::UserAgent. LWP::UserAgent will then call
3346 # $self->get_basic_credentials or some equivalent and this will be
3347 # $self->dispatched to our own get_basic_credentials method.
3348
3349 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3350
3351 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3352 # although we have gone through our get_basic_credentials, the proxy
3353 # server refuses to connect. This could be a case where the username or
3354 # password has changed in the meantime, so I'm trying once again without
3355 # $USER and $PASSWD to give the get_basic_credentials routine another
3356 # chance to set $USER and $PASSWD.
3357
3358 # mirror(): Its purpose is to deal with proxy authentication. When we
3359 # call SUPER::mirror, we relly call the mirror method in
3360 # LWP::UserAgent. LWP::UserAgent will then call
3361 # $self->get_basic_credentials or some equivalent and this will be
3362 # $self->dispatched to our own get_basic_credentials method.
3363
3364 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3365
3366 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3367 # although we have gone through our get_basic_credentials, the proxy
3368 # server refuses to connect. This could be a case where the username or
3369 # password has changed in the meantime, so I'm trying once again without
3370 # $USER and $PASSWD to give the get_basic_credentials routine another
3371 # chance to set $USER and $PASSWD.
3372
3373 sub mirror {
3374     my($self,$url,$aslocal) = @_;
3375     my $result = $self->SUPER::mirror($url,$aslocal);
3376     if ($result->code == 407) {
3377         undef $USER;
3378         undef $PASSWD;
3379         $result = $self->SUPER::mirror($url,$aslocal);
3380     }
3381     $result;
3382 }
3383
3384 package CPAN::FTP;
3385 use strict;
3386
3387 #-> sub CPAN::FTP::ftp_statistics
3388 # if they want to rewrite, they need to pass in a filehandle
3389 sub _ftp_statistics {
3390     my($self,$fh) = @_;
3391     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3392     $fh ||= FileHandle->new;
3393     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3394     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3395     my $sleep = 1;
3396     my $waitstart;
3397     while (!flock $fh, $locktype|LOCK_NB) {
3398         $waitstart ||= localtime();
3399         if ($sleep>3) {
3400             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3401         }
3402         $CPAN::Frontend->mysleep($sleep);
3403         if ($sleep <= 3) {
3404             $sleep+=0.33;
3405         } elsif ($sleep <=6) {
3406             $sleep+=0.11;
3407         }
3408     }
3409     my $stats = eval { CPAN->_yaml_loadfile($file); };
3410     if ($@) {
3411         if (ref $@) {
3412             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3413                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3414                 return;
3415             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3416                 $CPAN::Frontend->mydie($@);
3417             }
3418         } else {
3419             $CPAN::Frontend->mydie($@);
3420         }
3421     }
3422     return $stats->[0];
3423 }
3424
3425 #-> sub CPAN::FTP::_mytime
3426 sub _mytime () {
3427     if (CPAN->has_inst("Time::HiRes")) {
3428         return Time::HiRes::time();
3429     } else {
3430         return time;
3431     }
3432 }
3433
3434 #-> sub CPAN::FTP::_new_stats
3435 sub _new_stats {
3436     my($self,$file) = @_;
3437     my $ret = {
3438                file => $file,
3439                attempts => [],
3440                start => _mytime,
3441               };
3442     $ret;
3443 }
3444
3445 #-> sub CPAN::FTP::_add_to_statistics
3446 sub _add_to_statistics {
3447     my($self,$stats) = @_;
3448     my $yaml_module = CPAN::_yaml_module;
3449     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3450     if ($CPAN::META->has_inst($yaml_module)) {
3451         $stats->{thesiteurl} = $ThesiteURL;
3452         if (CPAN->has_inst("Time::HiRes")) {
3453             $stats->{end} = Time::HiRes::time();
3454         } else {
3455             $stats->{end} = time;
3456         }
3457         my $fh = FileHandle->new;
3458         my $time = time;
3459         my $sdebug = 0;
3460         my @debug;
3461         @debug = $time if $sdebug;
3462         my $fullstats = $self->_ftp_statistics($fh);
3463         close $fh;
3464         $fullstats->{history} ||= [];
3465         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3466         push @debug, time if $sdebug;
3467         push @{$fullstats->{history}}, $stats;
3468         # arbitrary hardcoded constants until somebody demands to have
3469         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3470         # YAML::Syck 0.82 has no noticable performance problem with 999;
3471         while (
3472                @{$fullstats->{history}} > 99
3473                || $time - $fullstats->{history}[0]{start} > 14*86400
3474               ) {
3475             shift @{$fullstats->{history}}
3476         }
3477         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3478         push @debug, time if $sdebug;
3479         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3480         # need no eval because if this fails, it is serious
3481         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3482         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3483         if ( $sdebug ) {
3484             local $CPAN::DEBUG = 512; # FTP
3485             push @debug, time;
3486             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3487                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3488                                 @debug,
3489                                ));
3490         }
3491         # Win32 cannot rename a file to an existing filename
3492         unlink($sfile) if ($^O eq 'MSWin32');
3493         rename "$sfile.$$", $sfile
3494             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3495     }
3496 }
3497
3498 # if file is CHECKSUMS, suggest the place where we got the file to be
3499 # checked from, maybe only for young files?
3500 #-> sub CPAN::FTP::_recommend_url_for
3501 sub _recommend_url_for {
3502     my($self, $file) = @_;
3503     my $urllist = $self->_get_urllist;
3504     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3505         my $fullstats = $self->_ftp_statistics();
3506         my $history = $fullstats->{history} || [];
3507         while (my $last = pop @$history) {
3508             last if $last->{end} - time > 3600; # only young results are interesting
3509             next unless $last->{file}; # dirname of nothing dies!
3510             next unless $file eq File::Basename::dirname($last->{file});
3511             return $last->{thesiteurl};
3512         }
3513     }
3514     if ($CPAN::Config->{randomize_urllist}
3515         &&
3516         rand(1) < $CPAN::Config->{randomize_urllist}
3517        ) {
3518         $urllist->[int rand scalar @$urllist];
3519     } else {
3520         return ();
3521     }
3522 }
3523
3524 #-> sub CPAN::FTP::_get_urllist
3525 sub _get_urllist {
3526     my($self) = @_;
3527     $CPAN::Config->{urllist} ||= [];
3528     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3529         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3530         $CPAN::Config->{urllist} = [];
3531     }
3532     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3533     for my $u (@urllist) {
3534         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3535         if (UNIVERSAL::can($u,"text")) {
3536             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3537         } else {
3538             $u .= "/" unless substr($u,-1) eq "/";
3539             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3540         }
3541     }
3542     \@urllist;
3543 }
3544
3545 #-> sub CPAN::FTP::ftp_get ;
3546 sub ftp_get {
3547     my($class,$host,$dir,$file,$target) = @_;
3548     $class->debug(
3549                   qq[Going to fetch file [$file] from dir [$dir]
3550         on host [$host] as local [$target]\n]
3551                  ) if $CPAN::DEBUG;
3552     my $ftp = Net::FTP->new($host);
3553     unless ($ftp) {
3554         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3555         return;
3556     }
3557     return 0 unless defined $ftp;
3558     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3559     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3560     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3561         my $msg = $ftp->message;
3562         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3563         return;
3564     }
3565     unless ( $ftp->cwd($dir) ){
3566         my $msg = $ftp->message;
3567         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3568         return;
3569     }
3570     $ftp->binary;
3571     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3572     unless ( $ftp->get($file,$target) ){
3573         my $msg = $ftp->message;
3574         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3575         return;
3576     }
3577     $ftp->quit; # it's ok if this fails
3578     return 1;
3579 }
3580
3581 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3582
3583  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3584  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3585  # > ***************
3586  # > *** 1562,1567 ****
3587  # > --- 1562,1580 ----
3588  # >       return 1 if substr($url,0,4) eq "file";
3589  # >       return 1 unless $url =~ m|://([^/]+)|;
3590  # >       my $host = $1;
3591  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3592  # > +     if ($proxy) {
3593  # > +         $proxy =~ m|://([^/:]+)|;
3594  # > +         $proxy = $1;
3595  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3596  # > +         if ($noproxy) {
3597  # > +             if ($host !~ /$noproxy$/) {
3598  # > +                 $host = $proxy;
3599  # > +             }
3600  # > +         } else {
3601  # > +             $host = $proxy;
3602  # > +         }
3603  # > +     }
3604  # >       require Net::Ping;
3605  # >       return 1 unless $Net::Ping::VERSION >= 2;
3606  # >       my $p;
3607
3608
3609 #-> sub CPAN::FTP::localize ;
3610 sub localize {
3611     my($self,$file,$aslocal,$force) = @_;
3612     $force ||= 0;
3613     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3614         unless defined $aslocal;
3615     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3616         if $CPAN::DEBUG;
3617
3618     if ($^O eq 'MacOS') {
3619         # Comment by AK on 2000-09-03: Uniq short filenames would be
3620         # available in CHECKSUMS file
3621         my($name, $path) = File::Basename::fileparse($aslocal, '');
3622         if (length($name) > 31) {
3623             $name =~ s/(
3624                         \.(
3625                            readme(\.(gz|Z))? |
3626                            (tar\.)?(gz|Z) |
3627                            tgz |
3628                            zip |
3629                            pm\.(gz|Z)
3630                           )
3631                        )$//x;
3632             my $suf = $1;
3633             my $size = 31 - length($suf);
3634             while (length($name) > $size) {
3635                 chop $name;
3636             }
3637             $name .= $suf;
3638             $aslocal = File::Spec->catfile($path, $name);
3639         }
3640     }
3641
3642     if (-f $aslocal && -r _ && !($force & 1)){
3643         my $size;
3644         if ($size = -s $aslocal) {
3645             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3646             return $aslocal;
3647         } else {
3648             # empty file from a previous unsuccessful attempt to download it
3649             unlink $aslocal or
3650                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3651                                        "could not remove.");
3652         }
3653     }
3654     my($maybe_restore) = 0;
3655     if (-f $aslocal){
3656         rename $aslocal, "$aslocal.bak$$";
3657         $maybe_restore++;
3658     }
3659
3660     my($aslocal_dir) = File::Basename::dirname($aslocal);
3661     File::Path::mkpath($aslocal_dir);
3662     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3663         qq{directory "$aslocal_dir".
3664     I\'ll continue, but if you encounter problems, they may be due
3665     to insufficient permissions.\n}) unless -w $aslocal_dir;
3666
3667     # Inheritance is not easier to manage than a few if/else branches
3668     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3669         unless ($Ua) {
3670             CPAN::LWP::UserAgent->config;
3671             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3672             if ($@) {
3673                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3674                     if $CPAN::DEBUG;
3675             } else {
3676                 my($var);
3677                 $Ua->proxy('ftp',  $var)
3678                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3679                 $Ua->proxy('http', $var)
3680                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3681                 $Ua->no_proxy($var)
3682                     if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
3683             }
3684         }
3685     }
3686     for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
3687         $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
3688     }
3689
3690     # Try the list of urls for each single object. We keep a record
3691     # where we did get a file from
3692     my(@reordered,$last);
3693     my $ccurllist = $self->_get_urllist;
3694     $last = $#$ccurllist;
3695     if ($force & 2) { # local cpans probably out of date, don't reorder
3696         @reordered = (0..$last);
3697     } else {
3698         @reordered =
3699             sort {
3700                 (substr($ccurllist->[$b],0,4) eq "file")
3701                     <=>
3702                 (substr($ccurllist->[$a],0,4) eq "file")
3703                     or
3704                 defined($ThesiteURL)
3705                     and
3706                 ($ccurllist->[$b] eq $ThesiteURL)
3707                     <=>
3708                 ($ccurllist->[$a] eq $ThesiteURL)
3709             } 0..$last;
3710     }
3711     my(@levels);
3712     $Themethod ||= "";
3713     $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
3714     if ($Themethod) {
3715         @levels = ($Themethod, grep {$_ ne $Themethod} qw/easy hard hardest/);
3716     } else {
3717         @levels = qw/easy hard hardest/;
3718     }
3719     @levels = qw/easy/ if $^O eq 'MacOS';
3720     my($levelno);
3721     local $ENV{FTP_PASSIVE} =
3722         exists $CPAN::Config->{ftp_passive} ?
3723         $CPAN::Config->{ftp_passive} : 1;
3724     my $ret;
3725     my $stats = $self->_new_stats($file);
3726   LEVEL: for $levelno (0..$#levels) {
3727         my $level = $levels[$levelno];
3728         my $method = "host$level";
3729         my @host_seq = $level eq "easy" ?
3730             @reordered : 0..$last;  # reordered has CDROM up front
3731         my @urllist = map { $ccurllist->[$_] } @host_seq;
3732         for my $u (@CPAN::Defaultsites) {
3733             push @urllist, $u unless grep { $_ eq $u } @urllist;
3734         }
3735         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3736         my $aslocal_tempfile = $aslocal . ".tmp" . $$;
3737         if (my $recommend = $self->_recommend_url_for($file)) {
3738             @urllist = grep { $_ ne $recommend } @urllist;
3739             unshift @urllist, $recommend;
3740         }
3741         $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
3742         $ret = $self->$method(\@urllist,$file,$aslocal_tempfile,$stats);
3743         if ($ret) {
3744             CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
3745             if ($ret eq $aslocal_tempfile) {
3746                 # if we got it exactly as we asked for, only then we
3747                 # want to rename
3748                 rename $aslocal_tempfile, $aslocal
3749                     or $CPAN::Frontend->mydie("Error while trying to rename ".
3750                                               "'$ret' to '$aslocal': $!");
3751                 $ret = $aslocal;
3752             }
3753             $Themethod = $level;
3754             my $now = time;
3755             # utime $now, $now, $aslocal; # too bad, if we do that, we
3756                                           # might alter a local mirror
3757             $self->debug("level[$level]") if $CPAN::DEBUG;
3758             last LEVEL;
3759         } else {
3760             unlink $aslocal_tempfile;
3761             last if $CPAN::Signal; # need to cleanup
3762         }
3763     }
3764     if ($ret) {
3765         $stats->{filesize} = -s $ret;
3766     }
3767     $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
3768     $self->_add_to_statistics($stats);
3769     $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
3770     if ($ret) {
3771         unlink "$aslocal.bak$$";
3772         return $ret;
3773     }
3774     unless ($CPAN::Signal) {
3775         my(@mess);
3776         local $" = " ";
3777         if (@{$CPAN::Config->{urllist}}) {
3778             push @mess,
3779                 qq{Please check, if the URLs I found in your configuration file \(}.
3780                     join(", ", @{$CPAN::Config->{urllist}}).
3781                         qq{\) are valid.};
3782         } else {
3783             push @mess, qq{Your urllist is empty!};
3784         }
3785         push @mess, qq{The urllist can be edited.},
3786             qq{E.g. with 'o conf urllist push ftp://myurl/'};
3787         $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
3788         $CPAN::Frontend->mywarn("Could not fetch $file\n");
3789         $CPAN::Frontend->mysleep(2);
3790     }
3791     if ($maybe_restore) {
3792         rename "$aslocal.bak$$", $aslocal;
3793         $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
3794                                  $self->ls($aslocal));
3795         return $aslocal;
3796     }
3797     return;
3798 }
3799
3800 sub _set_attempt {
3801     my($self,$stats,$method,$url) = @_;
3802     push @{$stats->{attempts}}, {
3803                                  method => $method,
3804                                  start => _mytime,
3805                                  url => $url,
3806                                 };
3807 }
3808
3809 # package CPAN::FTP;
3810 sub hosteasy {
3811     my($self,$host_seq,$file,$aslocal,$stats) = @_;
3812     my($ro_url);
3813   HOSTEASY: for $ro_url (@$host_seq) {
3814         $self->_set_attempt($stats,"easy",$ro_url);
3815         my $url .= "$ro_url$file";
3816         $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
3817         if ($url =~ /^file:/) {
3818             my $l;
3819             if ($CPAN::META->has_inst('URI::URL')) {
3820                 my $u =  URI::URL->new($url);
3821                 $l = $u->path;
3822             } else { # works only on Unix, is poorly constructed, but
3823                 # hopefully better than nothing.
3824                 # RFC 1738 says fileurl BNF is
3825                 # fileurl = "file://" [ host | "localhost" ] "/" fpath
3826                 # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
3827                 # the code
3828                 ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
3829                 $l =~ s|^file:||;                   # assume they
3830                                                     # meant
3831                                                     # file://localhost
3832                 $l =~ s|^/||s
3833                     if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
3834             }
3835             $self->debug("local file[$l]") if $CPAN::DEBUG;
3836             if ( -f $l && -r _) {
3837                 $ThesiteURL = $ro_url;
3838                 return $l;
3839             }
3840             if ($l =~ /(.+)\.gz$/) {
3841                 my $ungz = $1;
3842                 if ( -f $ungz && -r _) {
3843                     $ThesiteURL = $ro_url;
3844                     return $ungz;
3845                 }
3846             }
3847             # Maybe mirror has compressed it?
3848             if (-f "$l.gz") {
3849                 $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
3850                 eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
3851                 if ( -f $aslocal) {
3852                     $ThesiteURL = $ro_url;
3853                     return $aslocal;
3854                 }
3855             }
3856         }
3857         $self->debug("it was not a file URL") if $CPAN::DEBUG;
3858         if ($CPAN::META->has_usable('LWP')) {
3859             $CPAN::Frontend->myprint("Fetching with LWP:
3860   $url
3861 ");
3862             unless ($Ua) {
3863                 CPAN::LWP::UserAgent->config;
3864                 eval { $Ua = CPAN::LWP::UserAgent->new; };
3865                 if ($@) {
3866                     $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
3867                 }
3868             }
3869             my $res = $Ua->mirror($url, $aslocal);
3870             if ($res->is_success) {
3871                 $ThesiteURL = $ro_url;
3872                 my $now = time;
3873                 utime $now, $now, $aslocal; # download time is more
3874                                             # important than upload
3875                                             # time
3876                 return $aslocal;
3877             } elsif ($url !~ /\.gz(?!\n)\Z/) {
3878                 my $gzurl = "$url.gz";
3879                 $CPAN::Frontend->myprint("Fetching with LWP:
3880   $gzurl
3881 ");
3882                 $res = $Ua->mirror($gzurl, "$aslocal.gz");
3883                 if ($res->is_success) {
3884                     if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
3885                         $ThesiteURL = $ro_url;
3886                         return $aslocal;
3887                     }
3888                 }
3889             } else {
3890                 $CPAN::Frontend->myprint(sprintf(
3891                                                  "LWP failed with code[%s] message[%s]\n",
3892                                                  $res->code,
3893                                                  $res->message,
3894                                                 ));
3895                 # Alan Burlison informed me that in firewall environments
3896                 # Net::FTP can still succeed where LWP fails. So we do not
3897                 # skip Net::FTP anymore when LWP is available.
3898             }
3899         } else {
3900             $CPAN::Frontend->mywarn("  LWP not available\n");
3901         }
3902         return if $CPAN::Signal;
3903         if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3904             # that's the nice and easy way thanks to Graham
3905             $self->debug("recognized ftp") if $CPAN::DEBUG;
3906             my($host,$dir,$getfile) = ($1,$2,$3);
3907             if ($CPAN::META->has_usable('Net::FTP')) {
3908                 $dir =~ s|/+|/|g;
3909                 $CPAN::Frontend->myprint("Fetching with Net::FTP:
3910   $url
3911 ");
3912                 $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
3913                              "aslocal[$aslocal]") if $CPAN::DEBUG;
3914                 if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
3915                     $ThesiteURL = $ro_url;
3916                     return $aslocal;
3917                 }
3918                 if ($aslocal !~ /\.gz(?!\n)\Z/) {
3919                     my $gz = "$aslocal.gz";
3920                     $CPAN::Frontend->myprint("Fetching with Net::FTP
3921   $url.gz
3922 ");
3923                     if (CPAN::FTP->ftp_get($host,
3924                                            $dir,
3925                                            "$getfile.gz",
3926                                            $gz) &&
3927                         eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
3928                        ){
3929                         $ThesiteURL = $ro_url;
3930                         return $aslocal;
3931                     }
3932                 }
3933                 # next HOSTEASY;
3934             } else {
3935                 CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
3936             }
3937         }
3938         if (
3939             UNIVERSAL::can($ro_url,"text")
3940             and
3941             $ro_url->{FROM} eq "USER"
3942            ){
3943             ##address #17973: default URLs should not try to override
3944             ##user-defined URLs just because LWP is not available
3945             my $ret = $self->hosthard([$ro_url],$file,$aslocal,$stats);
3946             return $ret if $ret;
3947         }
3948         return if $CPAN::Signal;
3949     }
3950 }
3951
3952 # package CPAN::FTP;
3953 sub hosthard {
3954   my($self,$host_seq,$file,$aslocal,$stats) = @_;
3955
3956   # Came back if Net::FTP couldn't establish connection (or
3957   # failed otherwise) Maybe they are behind a firewall, but they
3958   # gave us a socksified (or other) ftp program...
3959
3960   my($ro_url);
3961   my($devnull) = $CPAN::Config->{devnull} || "";
3962   # < /dev/null ";
3963   my($aslocal_dir) = File::Basename::dirname($aslocal);
3964   File::Path::mkpath($aslocal_dir);
3965   HOSTHARD: for $ro_url (@$host_seq) {
3966         $self->_set_attempt($stats,"hard",$ro_url);
3967         my $url = "$ro_url$file";
3968         my($proto,$host,$dir,$getfile);
3969
3970         # Courtesy Mark Conty mark_conty@cargill.com change from
3971         # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
3972         # to
3973         if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
3974           # proto not yet used
3975           ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
3976         } else {
3977           next HOSTHARD; # who said, we could ftp anything except ftp?
3978         }
3979         next HOSTHARD if $proto eq "file"; # file URLs would have had
3980                                            # success above. Likely a bogus URL
3981
3982         $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;
3983
3984         # Try the most capable first and leave ncftp* for last as it only
3985         # does FTP.
3986       DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
3987           my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
3988           next unless defined $funkyftp;
3989           next if $funkyftp =~ /^\s*$/;
3990
3991           my($asl_ungz, $asl_gz);
3992           ($asl_ungz = $aslocal) =~ s/\.gz//;
3993           $asl_gz = "$asl_ungz.gz";
3994
3995           my($src_switch) = "";
3996           my($chdir) = "";
3997           my($stdout_redir) = " > $asl_ungz";
3998           if ($f eq "lynx"){
3999             $src_switch = " -source";
4000           } elsif ($f eq "ncftp"){
4001             $src_switch = " -c";
4002           } elsif ($f eq "wget"){
4003             $src_switch = " -O $asl_ungz";
4004             $stdout_redir = "";
4005           } elsif ($f eq 'curl'){
4006             $src_switch = ' -L -f -s -S --netrc-optional';
4007           }
4008
4009           if ($f eq "ncftpget"){
4010             $chdir = "cd $aslocal_dir && ";
4011             $stdout_redir = "";
4012           }
4013           $CPAN::Frontend->myprint(
4014                                    qq[
4015 Trying with "$funkyftp$src_switch" to get
4016     $url
4017 ]);
4018           my($system) =
4019               "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
4020           $self->debug("system[$system]") if $CPAN::DEBUG;
4021           my($wstatus) = system($system);
4022           if ($f eq "lynx") {
4023               # lynx returns 0 when it fails somewhere
4024               if (-s $asl_ungz) {
4025                   my $content = do { local *FH;
4026                                      open FH, $asl_ungz or die;
4027                                      local $/;
4028                                      <FH> };
4029                   if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
4030                       $CPAN::Frontend->mywarn(qq{
4031 No success, the file that lynx has has downloaded looks like an error message:
4032 $content
4033 });
4034                       $CPAN::Frontend->mysleep(1);
4035                       next DLPRG;
4036                   }
4037               } else {
4038                   $CPAN::Frontend->myprint(qq{
4039 No success, the file that lynx has has downloaded is an empty file.
4040 });
4041                   next DLPRG;
4042               }
4043           }
4044           if ($wstatus == 0) {
4045             if (-s $aslocal) {
4046               # Looks good
4047             } elsif ($asl_ungz ne $aslocal) {
4048               # test gzip integrity
4049               if (eval{CPAN::Tarzip->new($asl_ungz)->gtest}) {
4050                   # e.g. foo.tar is gzipped --> foo.tar.gz
4051                   rename $asl_ungz, $aslocal;
4052               } else {
4053                   eval{CPAN::Tarzip->new($asl_gz)->gzip($asl_ungz)};
4054               }
4055             }
4056             $ThesiteURL = $ro_url;
4057             return $aslocal;
4058           } elsif ($url !~ /\.gz(?!\n)\Z/) {
4059             unlink $asl_ungz if
4060                 -f $asl_ungz && -s _ == 0;
4061             my $gz = "$aslocal.gz";
4062             my $gzurl = "$url.gz";
4063             $CPAN::Frontend->myprint(
4064                                      qq[
4065 Trying with "$funkyftp$src_switch" to get
4066   $url.gz
4067 ]);
4068             my($system) = "$funkyftp$src_switch \"$url.gz\" $devnull > $asl_gz";
4069             $self->debug("system[$system]") if $CPAN::DEBUG;
4070             my($wstatus);
4071             if (($wstatus = system($system)) == 0
4072                 &&
4073                 -s $asl_gz
4074                ) {
4075               # test gzip integrity
4076                 my $ct = eval{CPAN::Tarzip->new($asl_gz)};
4077                 if ($ct && $ct->gtest) {
4078                     $ct->gunzip($aslocal);
4079                 } else {
4080                     # somebody uncompressed file for us?
4081                     rename $asl_ungz, $aslocal;
4082                 }
4083                 $ThesiteURL = $ro_url;
4084                 return $aslocal;
4085             } else {
4086               unlink $asl_gz if -f $asl_gz;
4087             }
4088           } else {
4089             my $estatus = $wstatus >> 8;
4090             my $size = -f $aslocal ?
4091                 ", left\n$aslocal with size ".-s _ :
4092                     "\nWarning: expected file [$aslocal] doesn't exist";
4093             $CPAN::Frontend->myprint(qq{
4094 System call "$system"
4095 returned status $estatus (wstat $wstatus)$size
4096 });
4097           }
4098           return if $CPAN::Signal;
4099         } # transfer programs
4100     } # host
4101 }
4102
4103 # package CPAN::FTP;
4104 sub hosthardest {
4105     my($self,$host_seq,$file,$aslocal,$stats) = @_;
4106
4107     my($ro_url);
4108     my($aslocal_dir) = File::Basename::dirname($aslocal);
4109     File::Path::mkpath($aslocal_dir);
4110     my $ftpbin = $CPAN::Config->{ftp};
4111     unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
4112         $CPAN::Frontend->myprint("No external ftp command available\n\n");
4113         return;
4114     }
4115     $CPAN::Frontend->mywarn(qq{
4116 As a last ressort we now switch to the external ftp command '$ftpbin'
4117 to get '$aslocal'.
4118
4119 Doing so often leads to problems that are hard to diagnose.
4120
4121 If you're victim of such problems, please consider unsetting the ftp
4122 config variable with
4123
4124     o conf ftp ""
4125     o conf commit
4126
4127 });
4128     $CPAN::Frontend->mysleep(2);
4129   HOSTHARDEST: for $ro_url (@$host_seq) {
4130         $self->_set_attempt($stats,"hardest",$ro_url);
4131         my $url = "$ro_url$file";
4132         $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
4133         unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
4134             next;
4135         }
4136         my($host,$dir,$getfile) = ($1,$2,$3);
4137         my $timestamp = 0;
4138         my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
4139            $ctime,$blksize,$blocks) = stat($aslocal);
4140         $timestamp = $mtime ||= 0;
4141         my($netrc) = CPAN::FTP::netrc->new;
4142         my($netrcfile) = $netrc->netrc;
4143         my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
4144         my $targetfile = File::Basename::basename($aslocal);
4145         my(@dialog);
4146         push(
4147              @dialog,
4148              "lcd $aslocal_dir",
4149              "cd /",
4150              map("cd $_", split /\//, $dir), # RFC 1738
4151              "bin",
4152              "get $getfile $targetfile",
4153              "quit"
4154             );
4155         if (! $netrcfile) {
4156             CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
4157         } elsif ($netrc->hasdefault || $netrc->contains($host)) {
4158             CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
4159                                 $netrc->hasdefault,
4160                                 $netrc->contains($host))) if $CPAN::DEBUG;
4161             if ($netrc->protected) {
4162                 my $dialog = join "", map { "    $_\n" } @dialog;
4163                 my $netrc_explain;
4164                 if ($netrc->contains($host)) {
4165                     $netrc_explain = "Relying that your .netrc entry for '$host' ".
4166                         "manages the login";
4167                 } else {
4168                     $netrc_explain = "Relying that your default .netrc entry ".
4169                         "manages the login";
4170                 }
4171                 $CPAN::Frontend->myprint(qq{
4172   Trying with external ftp to get
4173     $url
4174   $netrc_explain
4175   Going to send the dialog
4176 $dialog
4177 }
4178                      );
4179                 $self->talk_ftp("$ftpbin$verbose $host",
4180                                 @dialog);
4181                 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4182                  $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4183                 $mtime ||= 0;
4184                 if ($mtime > $timestamp) {
4185                     $CPAN::Frontend->myprint("GOT $aslocal\n");
4186                     $ThesiteURL = $ro_url;
4187                     return $aslocal;
4188                 } else {
4189                     $CPAN::Frontend->myprint("Hmm... Still failed!\n");
4190                 }
4191                 return if $CPAN::Signal;
4192             } else {
4193                 $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
4194                                         qq{correctly protected.\n});
4195             }
4196         } else {
4197             $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
4198   nor does it have a default entry\n");
4199         }
4200
4201         # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
4202         # then and login manually to host, using e-mail as
4203         # password.
4204         $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
4205         unshift(
4206                 @dialog,
4207                 "open $host",
4208                 "user anonymous $Config::Config{'cf_email'}"
4209                );
4210         my $dialog = join "", map { "    $_\n" } @dialog;
4211         $CPAN::Frontend->myprint(qq{
4212   Trying with external ftp to get
4213     $url
4214   Going to send the dialog
4215 $dialog
4216 }
4217                      );
4218         $self->talk_ftp("$ftpbin$verbose -n", @dialog);
4219         ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4220          $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
4221         $mtime ||= 0;
4222         if ($mtime > $timestamp) {
4223             $CPAN::Frontend->myprint("GOT $aslocal\n");
4224             $ThesiteURL = $ro_url;
4225             return $aslocal;
4226         } else {
4227             $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
4228         }
4229         return if $CPAN::Signal;
4230         $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
4231         $CPAN::Frontend->mysleep(2);
4232     } # host
4233 }
4234
4235 # package CPAN::FTP;
4236 sub talk_ftp {
4237     my($self,$command,@dialog) = @_;
4238     my $fh = FileHandle->new;
4239     $fh->open("|$command") or die "Couldn't open ftp: $!";
4240     foreach (@dialog) { $fh->print("$_\n") }
4241     $fh->close;         # Wait for process to complete
4242     my $wstatus = $?;
4243     my $estatus = $wstatus >> 8;
4244     $CPAN::Frontend->myprint(qq{
4245 Subprocess "|$command"
4246   returned status $estatus (wstat $wstatus)
4247 }) if $wstatus;
4248 }
4249
4250 # find2perl needs modularization, too, all the following is stolen
4251 # from there
4252 # CPAN::FTP::ls
4253 sub ls {
4254     my($self,$name) = @_;
4255     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
4256      $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);
4257
4258     my($perms,%user,%group);
4259     my $pname = $name;
4260
4261     if ($blocks) {
4262         $blocks = int(($blocks + 1) / 2);
4263     }
4264     else {
4265         $blocks = int(($sizemm + 1023) / 1024);
4266     }
4267
4268     if    (-f _) { $perms = '-'; }
4269     elsif (-d _) { $perms = 'd'; }
4270     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
4271     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
4272     elsif (-p _) { $perms = 'p'; }
4273     elsif (-S _) { $perms = 's'; }
4274     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
4275
4276     my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
4277     my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
4278     my $tmpmode = $mode;
4279     my $tmp = $rwx[$tmpmode & 7];
4280     $tmpmode >>= 3;
4281     $tmp = $rwx[$tmpmode & 7] . $tmp;
4282     $tmpmode >>= 3;
4283     $tmp = $rwx[$tmpmode & 7] . $tmp;
4284     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
4285     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
4286     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
4287     $perms .= $tmp;
4288
4289     my $user = $user{$uid} || $uid;   # too lazy to implement lookup
4290     my $group = $group{$gid} || $gid;
4291
4292     my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
4293     my($timeyear);
4294     my($moname) = $moname[$mon];
4295     if (-M _ > 365.25 / 2) {
4296         $timeyear = $year + 1900;
4297     }
4298     else {
4299         $timeyear = sprintf("%02d:%02d", $hour, $min);
4300     }
4301
4302     sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
4303             $ino,
4304                  $blocks,
4305                       $perms,
4306                             $nlink,
4307                                 $user,
4308                                      $group,
4309                                           $sizemm,
4310                                               $moname,
4311                                                  $mday,
4312                                                      $timeyear,
4313                                                          $pname;
4314 }
4315
4316 package CPAN::FTP::netrc;
4317 use strict;
4318
4319 # package CPAN::FTP::netrc;
4320 sub new {
4321     my($class) = @_;
4322     my $home = CPAN::HandleConfig::home;
4323     my $file = File::Spec->catfile($home,".netrc");
4324
4325     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
4326        $atime,$mtime,$ctime,$blksize,$blocks)
4327         = stat($file);
4328     $mode ||= 0;
4329     my $protected = 0;
4330
4331     my($fh,@machines,$hasdefault);
4332     $hasdefault = 0;
4333     $fh = FileHandle->new or die "Could not create a filehandle";
4334
4335     if($fh->open($file)){
4336         $protected = ($mode & 077) == 0;
4337         local($/) = "";
4338       NETRC: while (<$fh>) {
4339             my(@tokens) = split " ", $_;
4340           TOKEN: while (@tokens) {
4341                 my($t) = shift @tokens;
4342                 if ($t eq "default"){
4343                     $hasdefault++;
4344                     last NETRC;
4345                 }
4346                 last TOKEN if $t eq "macdef";
4347                 if ($t eq "machine") {
4348                     push @machines, shift @tokens;
4349                 }
4350             }
4351         }
4352     } else {
4353         $file = $hasdefault = $protected = "";
4354     }
4355
4356     bless {
4357            'mach' => [@machines],
4358            'netrc' => $file,
4359            'hasdefault' => $hasdefault,
4360            'protected' => $protected,
4361           }, $class;
4362 }
4363
4364 # CPAN::FTP::netrc::hasdefault;
4365 sub hasdefault { shift->{'hasdefault'} }
4366 sub netrc      { shift->{'netrc'}      }
4367 sub protected  { shift->{'protected'}  }
4368 sub contains {
4369     my($self,$mach) = @_;
4370     for ( @{$self->{'mach'}} ) {
4371         return 1 if $_ eq $mach;
4372     }
4373     return 0;
4374 }
4375
4376 package CPAN::Complete;
4377 use strict;
4378
4379 sub gnu_cpl {
4380     my($text, $line, $start, $end) = @_;
4381     my(@perlret) = cpl($text, $line, $start);
4382     # find longest common match. Can anybody show me how to peruse
4383     # T::R::Gnu to have this done automatically? Seems expensive.
4384     return () unless @perlret;
4385     my($newtext) = $text;
4386     for (my $i = length($text)+1;;$i++) {
4387         last unless length($perlret[0]) && length($perlret[0]) >= $i;
4388         my $try = substr($perlret[0],0,$i);
4389         my @tries = grep {substr($_,0,$i) eq $try} @perlret;
4390         # warn "try[$try]tries[@tries]";
4391         if (@tries == @perlret) {
4392             $newtext = $try;
4393         } else {
4394             last;
4395         }
4396     }
4397     ($newtext,@perlret);
4398 }
4399
4400 #-> sub CPAN::Complete::cpl ;
4401 sub cpl {
4402     my($word,$line,$pos) = @_;
4403     $word ||= "";
4404     $line ||= "";
4405     $pos ||= 0;
4406     CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4407     $line =~ s/^\s*//;
4408     if ($line =~ s/^((?:notest|f?force)\s*)//) {
4409         $pos -= length($1);
4410     }
4411     my @return;
4412     if ($pos == 0) {
4413         @return = grep /^$word/, @CPAN::Complete::COMMANDS;
4414     } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
4415         @return = ();
4416     } elsif ($line =~ /^(a|ls)\s/) {
4417         @return = cplx('CPAN::Author',uc($word));
4418     } elsif ($line =~ /^b\s/) {
4419         CPAN::Shell->local_bundles;
4420         @return = cplx('CPAN::Bundle',$word);
4421     } elsif ($line =~ /^d\s/) {
4422         @return = cplx('CPAN::Distribution',$word);
4423     } elsif ($line =~ m/^(
4424                           [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
4425                          )\s/x ) {
4426         if ($word =~ /^Bundle::/) {
4427             CPAN::Shell->local_bundles;
4428         }
4429         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4430     } elsif ($line =~ /^i\s/) {
4431         @return = cpl_any($word);
4432     } elsif ($line =~ /^reload\s/) {
4433         @return = cpl_reload($word,$line,$pos);
4434     } elsif ($line =~ /^o\s/) {
4435         @return = cpl_option($word,$line,$pos);
4436     } elsif ($line =~ m/^\S+\s/ ) {
4437         # fallback for future commands and what we have forgotten above
4438         @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
4439     } else {
4440         @return = ();
4441     }
4442     return @return;
4443 }
4444
4445 #-> sub CPAN::Complete::cplx ;
4446 sub cplx {
4447     my($class, $word) = @_;
4448     if (CPAN::_sqlite_running) {
4449         $CPAN::SQLite->search($class, "^\Q$word\E");
4450     }
4451     sort grep /^\Q$word\E/, map { $_->id } $CPAN::META->all_objects($class);
4452 }
4453
4454 #-> sub CPAN::Complete::cpl_any ;
4455 sub cpl_any {
4456     my($word) = shift;
4457     return (
4458             cplx('CPAN::Author',$word),
4459             cplx('CPAN::Bundle',$word),
4460             cplx('CPAN::Distribution',$word),
4461             cplx('CPAN::Module',$word),
4462            );
4463 }
4464
4465 #-> sub CPAN::Complete::cpl_reload ;
4466 sub cpl_reload {
4467     my($word,$line,$pos) = @_;
4468     $word ||= "";
4469     my(@words) = split " ", $line;
4470     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4471     my(@ok) = qw(cpan index);
4472     return @ok if @words == 1;
4473     return grep /^\Q$word\E/, @ok if @words == 2 && $word;
4474 }
4475
4476 #-> sub CPAN::Complete::cpl_option ;
4477 sub cpl_option {
4478     my($word,$line,$pos) = @_;
4479     $word ||= "";
4480     my(@words) = split " ", $line;
4481     CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
4482     my(@ok) = qw(conf debug);
4483     return @ok if @words == 1;
4484     return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
4485     if (0) {
4486     } elsif ($words[1] eq 'index') {
4487         return ();
4488     } elsif ($words[1] eq 'conf') {
4489         return CPAN::HandleConfig::cpl(@_);
4490     } elsif ($words[1] eq 'debug') {
4491         return sort grep /^\Q$word\E/i,
4492             sort keys %CPAN::DEBUG, 'all';
4493     }
4494 }
4495
4496 package CPAN::Index;
4497 use strict;
4498
4499 #-> sub CPAN::Index::force_reload ;
4500 sub force_reload {
4501     my($class) = @_;
4502     $CPAN::Index::LAST_TIME = 0;
4503     $class->reload(1);
4504 }
4505
4506 #-> sub CPAN::Index::reload ;
4507 sub reload {
4508     my($self,$force) = @_;
4509     my $time = time;
4510
4511     # XXX check if a newer one is available. (We currently read it
4512     # from time to time)
4513     for ($CPAN::Config->{index_expire}) {
4514         $_ = 0.001 unless $_ && $_ > 0.001;
4515     }
4516     unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
4517         # debug here when CPAN doesn't seem to read the Metadata
4518         require Carp;
4519         Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
4520     }
4521     unless ($CPAN::META->{PROTOCOL}) {
4522         $self->read_metadata_cache;
4523         $CPAN::META->{PROTOCOL} ||= "1.0";
4524     }
4525     if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
4526         # warn "Setting last_time to 0";
4527         $LAST_TIME = 0; # No warning necessary
4528     }
4529     if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
4530         and ! $force){
4531         # called too often
4532         # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
4533     } elsif (0) {
4534         # IFF we are developing, it helps to wipe out the memory
4535         # between reloads, otherwise it is not what a user expects.
4536         undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
4537         $CPAN::META = CPAN->new;
4538     } else {
4539         my($debug,$t2);
4540         local $LAST_TIME = $time;
4541         local $CPAN::META->{PROTOCOL} = PROTOCOL;
4542
4543         my $needshort = $^O eq "dos";
4544
4545         $self->rd_authindex($self
4546                           ->reload_x(
4547                                      "authors/01mailrc.txt.gz",
4548                                      $needshort ?
4549                                      File::Spec->catfile('authors', '01mailrc.gz') :
4550                                      File::Spec->catfile('authors', '01mailrc.txt.gz'),
4551                                      $force));
4552         $t2 = time;
4553         $debug = "timing reading 01[".($t2 - $time)."]";
4554         $time = $t2;
4555         return if $CPAN::Signal; # this is sometimes lengthy
4556         $self->rd_modpacks($self
4557                          ->reload_x(
4558                                     "modules/02packages.details.txt.gz",
4559                                     $needshort ?
4560                                     File::Spec->catfile('modules', '02packag.gz') :
4561                                     File::Spec->catfile('modules', '02packages.details.txt.gz'),
4562                                     $force));
4563         $t2 = time;
4564         $debug .= "02[".($t2 - $time)."]";
4565         $time = $t2;
4566         return if $CPAN::Signal; # this is sometimes lengthy
4567         $self->rd_modlist($self
4568                         ->reload_x(
4569                                    "modules/03modlist.data.gz",
4570                                    $needshort ?
4571                                    File::Spec->catfile('modules', '03mlist.gz') :
4572                                    File::Spec->catfile('modules', '03modlist.data.gz'),
4573                                    $force));
4574         $self->write_metadata_cache;
4575         $t2 = time;
4576         $debug .= "03[".($t2 - $time)."]";
4577         $time = $t2;
4578         CPAN->debug($debug) if $CPAN::DEBUG;
4579     }
4580     if ($CPAN::Config->{build_dir_reuse}) {
4581         $self->reanimate_build_dir;
4582     }
4583     if (CPAN::_sqlite_running) {
4584         $CPAN::SQLite->reload(time => $time, force => $force)
4585             if not $LAST_TIME;
4586     }
4587     $LAST_TIME = $time;
4588     $CPAN::META->{PROTOCOL} = PROTOCOL;
4589 }
4590
4591 #-> sub CPAN::Index::reanimate_build_dir ;
4592 sub reanimate_build_dir {
4593     my($self) = @_;
4594     unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
4595         return;
4596     }
4597     return if $HAVE_REANIMATED++;
4598     my $d = $CPAN::Config->{build_dir};
4599     my $dh = DirHandle->new;
4600     opendir $dh, $d or return; # does not exist
4601     my $dirent;
4602     my $i = 0;
4603     my $painted = 0;
4604     my $restored = 0;
4605     $CPAN::Frontend->myprint("Going to read $CPAN::Config->{build_dir}/\n");
4606     my @candidates = map { $_->[0] }
4607         sort { $b->[1] <=> $a->[1] }
4608             map { [ $_, -M File::Spec->catfile($d,$_) ] }
4609                 grep {/\.yml$/} readdir $dh;
4610   DISTRO: for $i (0..$#candidates) {
4611         my $dirent = $candidates[$i];
4612         my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent))};
4613         if ($@) {
4614             warn "Error while parsing file '$dirent'; error: '$@'";
4615             next DISTRO;
4616         }
4617         my $c = $y->[0];
4618         if ($c && CPAN->_perl_fingerprint($c->{perl})) {
4619             my $key = $c->{distribution}{ID};
4620             for my $k (keys %{$c->{distribution}}) {
4621                 if ($c->{distribution}{$k}
4622                     && ref $c->{distribution}{$k}
4623                     && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
4624                     $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
4625                 }
4626             }
4627
4628             #we tried to restore only if element already
4629             #exists; but then we do not work with metadata
4630             #turned off.
4631             my $do
4632                 = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
4633                     = $c->{distribution};
4634             for my $skipper (qw(badtestcnt notest force_update)) {
4635                 delete $do->{$skipper};
4636             }
4637             # $DB::single = 1;
4638             if ($do->{make_test}
4639                 && $do->{build_dir}
4640                 && !(UNIVERSAL::can($do->{make_test},"failed") ?
4641                      $do->{make_test}->failed :
4642                      $do->{make_test} =~ /^YES/
4643                     )
4644                 && (
4645                     !$do->{install}
4646                     ||
4647                     $do->{install}->failed
4648                    )
4649                ) {
4650                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4651             }
4652             $restored++;
4653         }
4654         $i++;
4655         while (($painted/76) < ($i/@candidates)) {
4656             $CPAN::Frontend->myprint(".");
4657             $painted++;
4658         }
4659     }
4660     $CPAN::Frontend->myprint(sprintf(
4661                                      "DONE\nFound %s old build%s, restored the state of %s\n",
4662                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4663                                      @candidates==1 ? "" : "s",
4664                                      $restored || "none",
4665                                     ));
4666 }
4667
4668
4669 #-> sub CPAN::Index::reload_x ;
4670 sub reload_x {
4671     my($cl,$wanted,$localname,$force) = @_;
4672     $force |= 2; # means we're dealing with an index here
4673     CPAN::HandleConfig->load; # we should guarantee loading wherever
4674                               # we rely on Config XXX
4675     $localname ||= $wanted;
4676     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4677                                          $localname);
4678     if (
4679         -f $abs_wanted &&
4680         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4681         !($force & 1)
4682        ) {
4683         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4684         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4685                    qq{day$s. I\'ll use that.});
4686         return $abs_wanted;
4687     } else {
4688         $force |= 1; # means we're quite serious about it.
4689     }
4690     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4691 }
4692
4693 #-> sub CPAN::Index::rd_authindex ;
4694 sub rd_authindex {
4695     my($cl, $index_target) = @_;
4696     return unless defined $index_target;
4697     return if CPAN::_sqlite_running;
4698     my @lines;
4699     $CPAN::Frontend->myprint("Going to read $index_target\n");
4700     local(*FH);
4701     tie *FH, 'CPAN::Tarzip', $index_target;
4702     local($/) = "\n";
4703     local($_);
4704     push @lines, split /\012/ while <FH>;
4705     my $i = 0;
4706     my $painted = 0;
4707     foreach (@lines) {
4708         my($userid,$fullname,$email) =
4709             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4710         $fullname ||= $email;
4711         if ($userid && $fullname && $email){
4712             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4713             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4714         } else {
4715             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4716         }
4717         $i++;
4718         while (($painted/76) < ($i/@lines)) {
4719             $CPAN::Frontend->myprint(".");
4720             $painted++;
4721         }
4722         return if $CPAN::Signal;
4723     }
4724     $CPAN::Frontend->myprint("DONE\n");
4725 }
4726
4727 sub userid {
4728   my($self,$dist) = @_;
4729   $dist = $self->{'id'} unless defined $dist;
4730   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4731   $ret;
4732 }
4733
4734 #-> sub CPAN::Index::rd_modpacks ;
4735 sub rd_modpacks {
4736     my($self, $index_target) = @_;
4737     return unless defined $index_target;
4738     return if CPAN::_sqlite_running;
4739     $CPAN::Frontend->myprint("Going to read $index_target\n");
4740     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4741     local $_;
4742     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4743     my $slurp = "";
4744     my $chunk;
4745     while (my $bytes = $fh->READ(\$chunk,8192)) {
4746         $slurp.=$chunk;
4747     }
4748     my @lines = split /\012/, $slurp;
4749     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4750     undef $fh;
4751     # read header
4752     my($line_count,$last_updated);
4753     while (@lines) {
4754         my $shift = shift(@lines);
4755         last if $shift =~ /^\s*$/;
4756         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4757         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4758     }
4759     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4760     if (not defined $line_count) {
4761
4762         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4763 Please check the validity of the index file by comparing it to more
4764 than one CPAN mirror. I'll continue but problems seem likely to
4765 happen.\a
4766 });
4767
4768         $CPAN::Frontend->mysleep(5);
4769     } elsif ($line_count != scalar @lines) {
4770
4771         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4772 contains a Line-Count header of %d but I see %d lines there. Please
4773 check the validity of the index file by comparing it to more than one
4774 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4775 $index_target, $line_count, scalar(@lines));
4776
4777     }
4778     if (not defined $last_updated) {
4779
4780         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4781 Please check the validity of the index file by comparing it to more
4782 than one CPAN mirror. I'll continue but problems seem likely to
4783 happen.\a
4784 });
4785
4786         $CPAN::Frontend->mysleep(5);
4787     } else {
4788
4789         $CPAN::Frontend
4790             ->myprint(sprintf qq{  Database was generated on %s\n},
4791                       $last_updated);
4792         $DATE_OF_02 = $last_updated;
4793
4794         my $age = time;
4795         if ($CPAN::META->has_inst('HTTP::Date')) {
4796             require HTTP::Date;
4797             $age -= HTTP::Date::str2time($last_updated);
4798         } else {
4799             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4800             require Time::Local;
4801             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4802             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4803             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4804         }
4805         $age /= 3600*24;
4806         if ($age > 30) {
4807
4808             $CPAN::Frontend
4809                 ->mywarn(sprintf
4810                          qq{Warning: This index file is %d days old.
4811   Please check the host you chose as your CPAN mirror for staleness.
4812   I'll continue but problems seem likely to happen.\a\n},
4813                          $age);
4814
4815         } elsif ($age < -1) {
4816
4817             $CPAN::Frontend
4818                 ->mywarn(sprintf
4819                          qq{Warning: Your system date is %d days behind this index file!
4820   System time:          %s
4821   Timestamp index file: %s
4822   Please fix your system time, problems with the make command expected.\n},
4823                          -$age,
4824                          scalar gmtime,
4825                          $DATE_OF_02,
4826                         );
4827
4828         }
4829     }
4830
4831
4832     # A necessity since we have metadata_cache: delete what isn't
4833     # there anymore
4834     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4835     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4836     my(%exists);
4837     my $i = 0;
4838     my $painted = 0;
4839     foreach (@lines) {
4840         # before 1.56 we split into 3 and discarded the rest. From
4841         # 1.57 we assign remaining text to $comment thus allowing to
4842         # influence isa_perl
4843         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4844         my($bundle,$id,$userid);
4845
4846         if ($mod eq 'CPAN' &&
4847             ! (
4848                CPAN::Queue->exists('Bundle::CPAN') ||
4849                CPAN::Queue->exists('CPAN')
4850               )
4851            ) {
4852             local($^W)= 0;
4853             if ($version > $CPAN::VERSION){
4854                 $CPAN::Frontend->mywarn(qq{
4855   New CPAN.pm version (v$version) available.
4856   [Currently running version is v$CPAN::VERSION]
4857   You might want to try
4858     install CPAN
4859     reload cpan
4860   to both upgrade CPAN.pm and run the new version without leaving
4861   the current session.
4862
4863 }); #});
4864                 $CPAN::Frontend->mysleep(2);
4865                 $CPAN::Frontend->myprint(qq{\n});
4866             }
4867             last if $CPAN::Signal;
4868         } elsif ($mod =~ /^Bundle::(.*)/) {
4869             $bundle = $1;
4870         }
4871
4872         if ($bundle){
4873             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4874             # Let's make it a module too, because bundles have so much
4875             # in common with modules.
4876
4877             # Changed in 1.57_63: seems like memory bloat now without
4878             # any value, so commented out
4879
4880             # $CPAN::META->instance('CPAN::Module',$mod);
4881
4882         } else {
4883
4884             # instantiate a module object
4885             $id = $CPAN::META->instance('CPAN::Module',$mod);
4886
4887         }
4888
4889         # Although CPAN prohibits same name with different version the
4890         # indexer may have changed the version for the same distro
4891         # since the last time ("Force Reindexing" feature)
4892         if ($id->cpan_file ne $dist
4893             ||
4894             $id->cpan_version ne $version
4895            ){
4896             $userid = $id->userid || $self->userid($dist);
4897             $id->set(
4898                      'CPAN_USERID' => $userid,
4899                      'CPAN_VERSION' => $version,
4900                      'CPAN_FILE' => $dist,
4901                     );
4902         }
4903
4904         # instantiate a distribution object
4905         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4906           # we do not need CONTAINSMODS unless we do something with
4907           # this dist, so we better produce it on demand.
4908
4909           ## my $obj = $CPAN::META->instance(
4910           ##                              'CPAN::Distribution' => $dist
4911           ##                             );
4912           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4913         } else {
4914           $CPAN::META->instance(
4915                                 'CPAN::Distribution' => $dist
4916                                )->set(
4917                                       'CPAN_USERID' => $userid,
4918                                       'CPAN_COMMENT' => $comment,
4919                                      );
4920         }
4921         if ($secondtime) {
4922             for my $name ($mod,$dist) {
4923                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4924                 $exists{$name} = undef;
4925             }
4926         }
4927         $i++;
4928         while (($painted/76) < ($i/@lines)) {
4929             $CPAN::Frontend->myprint(".");
4930             $painted++;
4931         }
4932         return if $CPAN::Signal;
4933     }
4934     $CPAN::Frontend->myprint("DONE\n");
4935     if ($secondtime) {
4936         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4937             for my $o ($CPAN::META->all_objects($class)) {
4938                 next if exists $exists{$o->{ID}};
4939                 $CPAN::META->delete($class,$o->{ID});
4940                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4941                 #     if $CPAN::DEBUG;
4942             }
4943         }
4944     }
4945 }
4946
4947 #-> sub CPAN::Index::rd_modlist ;
4948 sub rd_modlist {
4949     my($cl,$index_target) = @_;
4950     return unless defined $index_target;
4951     return if CPAN::_sqlite_running;
4952     $CPAN::Frontend->myprint("Going to read $index_target\n");
4953     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4954     local $_;
4955     my $slurp = "";
4956     my $chunk;
4957     while (my $bytes = $fh->READ(\$chunk,8192)) {
4958         $slurp.=$chunk;
4959     }
4960     my @eval2 = split /\012/, $slurp;
4961
4962     while (@eval2) {
4963         my $shift = shift(@eval2);
4964         if ($shift =~ /^Date:\s+(.*)/){
4965             if ($DATE_OF_03 eq $1){
4966                 $CPAN::Frontend->myprint("Unchanged.\n");
4967                 return;
4968             }
4969             ($DATE_OF_03) = $1;
4970         }
4971         last if $shift =~ /^\s*$/;
4972     }
4973     push @eval2, q{CPAN::Modulelist->data;};
4974     local($^W) = 0;
4975     my($comp) = Safe->new("CPAN::Safe1");
4976     my($eval2) = join("\n", @eval2);
4977     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4978     my $ret = $comp->reval($eval2);
4979     Carp::confess($@) if $@;
4980     return if $CPAN::Signal;
4981     my $i = 0;
4982     my $until = keys(%$ret);
4983     my $painted = 0;
4984     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4985     for (keys %$ret) {
4986         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4987         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4988         $obj->set(%{$ret->{$_}});
4989         $i++;
4990         while (($painted/76) < ($i/$until)) {
4991             $CPAN::Frontend->myprint(".");
4992             $painted++;
4993         }
4994         return if $CPAN::Signal;
4995     }
4996     $CPAN::Frontend->myprint("DONE\n");
4997 }
4998
4999 #-> sub CPAN::Index::write_metadata_cache ;
5000 sub write_metadata_cache {
5001     my($self) = @_;
5002     return unless $CPAN::Config->{'cache_metadata'};
5003     return if CPAN::_sqlite_running;
5004     return unless $CPAN::META->has_usable("Storable");
5005     my $cache;
5006     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5007                       CPAN::Distribution)) {
5008         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5009     }
5010     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5011     $cache->{last_time} = $LAST_TIME;
5012     $cache->{DATE_OF_02} = $DATE_OF_02;
5013     $cache->{PROTOCOL} = PROTOCOL;
5014     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5015     eval { Storable::nstore($cache, $metadata_file) };
5016     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5017 }
5018
5019 #-> sub CPAN::Index::read_metadata_cache ;
5020 sub read_metadata_cache {
5021     my($self) = @_;
5022     return unless $CPAN::Config->{'cache_metadata'};
5023     return if CPAN::_sqlite_running;
5024     return unless $CPAN::META->has_usable("Storable");
5025     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5026     return unless -r $metadata_file and -f $metadata_file;
5027     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5028     my $cache;
5029     eval { $cache = Storable::retrieve($metadata_file) };
5030     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5031     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
5032         $LAST_TIME = 0;
5033         return;
5034     }
5035     if (exists $cache->{PROTOCOL}) {
5036         if (PROTOCOL > $cache->{PROTOCOL}) {
5037             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5038                                             "with protocol v%s, requiring v%s\n",
5039                                             $cache->{PROTOCOL},
5040                                             PROTOCOL)
5041                                    );
5042             return;
5043         }
5044     } else {
5045         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5046                                 "with protocol v1.0\n");
5047         return;
5048     }
5049     my $clcnt = 0;
5050     my $idcnt = 0;
5051     while(my($class,$v) = each %$cache) {
5052         next unless $class =~ /^CPAN::/;
5053         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5054         while (my($id,$ro) = each %$v) {
5055             $CPAN::META->{readwrite}{$class}{$id} ||=
5056                 $class->new(ID=>$id, RO=>$ro);
5057             $idcnt++;
5058         }
5059         $clcnt++;
5060     }
5061     unless ($clcnt) { # sanity check
5062         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5063         return;
5064     }
5065     if ($idcnt < 1000) {
5066         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5067                                  "in $metadata_file\n");
5068         return;
5069     }
5070     $CPAN::META->{PROTOCOL} ||=
5071         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5072                             # does initialize to some protocol
5073     $LAST_TIME = $cache->{last_time};
5074     $DATE_OF_02 = $cache->{DATE_OF_02};
5075     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5076         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5077     return;
5078 }
5079
5080 package CPAN::InfoObj;
5081 use strict;
5082
5083 sub ro {
5084     my $self = shift;
5085     exists $self->{RO} and return $self->{RO};
5086 }
5087
5088 #-> sub CPAN::InfoObj::cpan_userid
5089 sub cpan_userid {
5090     my $self = shift;
5091     my $ro = $self->ro;
5092     if ($ro) {
5093         return $ro->{CPAN_USERID} || "N/A";
5094     } else {
5095         $self->debug("ID[$self->{ID}]");
5096         # N/A for bundles found locally
5097         return "N/A";
5098     }
5099 }
5100
5101 sub id { shift->{ID}; }
5102
5103 #-> sub CPAN::InfoObj::new ;
5104 sub new {
5105     my $this = bless {}, shift;
5106     %$this = @_;
5107     $this
5108 }
5109
5110 # The set method may only be used by code that reads index data or
5111 # otherwise "objective" data from the outside world. All session
5112 # related material may do anything else with instance variables but
5113 # must not touch the hash under the RO attribute. The reason is that
5114 # the RO hash gets written to Metadata file and is thus persistent.
5115
5116 #-> sub CPAN::InfoObj::safe_chdir ;
5117 sub safe_chdir {
5118   my($self,$todir) = @_;
5119   # we die if we cannot chdir and we are debuggable
5120   Carp::confess("safe_chdir called without todir argument")
5121         unless defined $todir and length $todir;
5122   if (chdir $todir) {
5123     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5124         if $CPAN::DEBUG;
5125   } else {
5126     if (-e $todir) {
5127         unless (-x $todir) {
5128             unless (chmod 0755, $todir) {
5129                 my $cwd = CPAN::anycwd();
5130                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5131                                         "permission to change the permission; cannot ".
5132                                         "chdir to '$todir'\n");
5133                 $CPAN::Frontend->mysleep(5);
5134                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5135                                        qq{to todir[$todir]: $!});
5136             }
5137         }
5138     } else {
5139         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5140     }
5141     if (chdir $todir) {
5142       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5143           if $CPAN::DEBUG;
5144     } else {
5145       my $cwd = CPAN::anycwd();
5146       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5147                              qq{to todir[$todir] (a chmod has been issued): $!});
5148     }
5149   }
5150 }
5151
5152 #-> sub CPAN::InfoObj::set ;
5153 sub set {
5154     my($self,%att) = @_;
5155     my $class = ref $self;
5156
5157     # This must be ||=, not ||, because only if we write an empty
5158     # reference, only then the set method will write into the readonly
5159     # area. But for Distributions that spring into existence, maybe
5160     # because of a typo, we do not like it that they are written into
5161     # the readonly area and made permanent (at least for a while) and
5162     # that is why we do not "allow" other places to call ->set.
5163     unless ($self->id) {
5164         CPAN->debug("Bug? Empty ID, rejecting");
5165         return;
5166     }
5167     my $ro = $self->{RO} =
5168         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5169
5170     while (my($k,$v) = each %att) {
5171         $ro->{$k} = $v;
5172     }
5173 }
5174
5175 #-> sub CPAN::InfoObj::as_glimpse ;
5176 sub as_glimpse {
5177     my($self) = @_;
5178     my(@m);
5179     my $class = ref($self);
5180     $class =~ s/^CPAN:://;
5181     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5182     push @m, sprintf "%-15s %s\n", $class, $id;
5183     join "", @m;
5184 }
5185
5186 #-> sub CPAN::InfoObj::as_string ;
5187 sub as_string {
5188     my($self) = @_;
5189     my(@m);
5190     my $class = ref($self);
5191     $class =~ s/^CPAN:://;
5192     push @m, $class, " id = $self->{ID}\n";
5193     my $ro;
5194     unless ($ro = $self->ro) {
5195         if (substr($self->{ID},-1,1) eq ".") { # directory
5196             $ro = +{};
5197         } else {
5198             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5199         }
5200     }
5201     for (sort keys %$ro) {
5202         # next if m/^(ID|RO)$/;
5203         my $extra = "";
5204         if ($_ eq "CPAN_USERID") {
5205             $extra .= " (";
5206             $extra .= $self->fullname;
5207             my $email; # old perls!
5208             if ($email = $CPAN::META->instance("CPAN::Author",
5209                                                $self->cpan_userid
5210                                               )->email) {
5211                 $extra .= " <$email>";
5212             } else {
5213                 $extra .= " <no email>";
5214             }
5215             $extra .= ")";
5216         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5217             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5218             next;
5219         }
5220         next unless defined $ro->{$_};
5221         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5222     }
5223   KEY: for (sort keys %$self) {
5224         next if m/^(ID|RO)$/;
5225         unless (defined $self->{$_}) {
5226             delete $self->{$_};
5227             next KEY;
5228         }
5229         if (ref($self->{$_}) eq "ARRAY") {
5230           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5231         } elsif (ref($self->{$_}) eq "HASH") {
5232             my $value;
5233             if (/^CONTAINSMODS$/) {
5234                 $value = join(" ",sort keys %{$self->{$_}});
5235             } elsif (/^prereq_pm$/) {
5236                 my @value;
5237                 my $v = $self->{$_};
5238                 for my $x (sort keys %$v) {
5239                     my @svalue;
5240                     for my $y (sort keys %{$v->{$x}}) {
5241                         push @svalue, "$y=>$v->{$x}{$y}";
5242                     }
5243                     push @value, "$x\:" . join ",", @svalue if @svalue;
5244                 }
5245                 $value = join ";", @value;
5246             } else {
5247                 $value = $self->{$_};
5248             }
5249           push @m, sprintf(
5250                            "    %-12s %s\n",
5251                            $_,
5252                            $value,
5253                           );
5254         } else {
5255           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5256         }
5257     }
5258     join "", @m, "\n";
5259 }
5260
5261 #-> sub CPAN::InfoObj::fullname ;
5262 sub fullname {
5263     my($self) = @_;
5264     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5265 }
5266
5267 #-> sub CPAN::InfoObj::dump ;
5268 sub dump {
5269   my($self, $what) = @_;
5270   unless ($CPAN::META->has_inst("Data::Dumper")) {
5271       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5272   }
5273   local $Data::Dumper::Sortkeys;
5274   $Data::Dumper::Sortkeys = 1;
5275   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5276   if (length $out > 100000) {
5277       my $fh_pager = FileHandle->new;
5278       local($SIG{PIPE}) = "IGNORE";
5279       my $pager = $CPAN::Config->{'pager'} || "cat";
5280       $fh_pager->open("|$pager")
5281           or die "Could not open pager $pager\: $!";
5282       $fh_pager->print($out);
5283       close $fh_pager;
5284   } else {
5285       $CPAN::Frontend->myprint($out);
5286   }
5287 }
5288
5289 package CPAN::Author;
5290 use strict;
5291
5292 #-> sub CPAN::Author::force
5293 sub force {
5294     my $self = shift;
5295     $self->{force}++;
5296 }
5297
5298 #-> sub CPAN::Author::force
5299 sub unforce {
5300     my $self = shift;
5301     delete $self->{force};
5302 }
5303
5304 #-> sub CPAN::Author::id
5305 sub id {
5306     my $self = shift;
5307     my $id = $self->{ID};
5308     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5309     $id;
5310 }
5311
5312 #-> sub CPAN::Author::as_glimpse ;
5313 sub as_glimpse {
5314     my($self) = @_;
5315     my(@m);
5316     my $class = ref($self);
5317     $class =~ s/^CPAN:://;
5318     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5319                      $class,
5320                      $self->{ID},
5321                      $self->fullname,
5322                      $self->email);
5323     join "", @m;
5324 }
5325
5326 #-> sub CPAN::Author::fullname ;
5327 sub fullname {
5328     shift->ro->{FULLNAME};
5329 }
5330 *name = \&fullname;
5331
5332 #-> sub CPAN::Author::email ;
5333 sub email    { shift->ro->{EMAIL}; }
5334
5335 #-> sub CPAN::Author::ls ;
5336 sub ls {
5337     my $self = shift;
5338     my $glob = shift || "";
5339     my $silent = shift || 0;
5340     my $id = $self->id;
5341
5342     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5343     my(@csf); # chksumfile
5344     @csf = $self->id =~ /(.)(.)(.*)/;
5345     $csf[1] = join "", @csf[0,1];
5346     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5347     my(@dl);
5348     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5349     unless (grep {$_->[2] eq $csf[1]} @dl) {
5350         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5351         return;
5352     }
5353     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5354     unless (grep {$_->[2] eq $csf[2]} @dl) {
5355         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5356         return;
5357     }
5358     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5359     if ($glob) {
5360         if ($CPAN::META->has_inst("Text::Glob")) {
5361             my $rglob = Text::Glob::glob_to_regex($glob);
5362             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5363         } else {
5364             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5365         }
5366     }
5367     $CPAN::Frontend->myprint(join "", map {
5368         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5369     } sort { $a->[2] cmp $b->[2] } @dl);
5370     @dl;
5371 }
5372
5373 # returns an array of arrays, the latter contain (size,mtime,filename)
5374 #-> sub CPAN::Author::dir_listing ;
5375 sub dir_listing {
5376     my $self = shift;
5377     my $chksumfile = shift;
5378     my $recursive = shift;
5379     my $may_ftp = shift;
5380
5381     my $lc_want =
5382         File::Spec->catfile($CPAN::Config->{keep_source_where},
5383                             "authors", "id", @$chksumfile);
5384
5385     my $fh;
5386
5387     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5388     # hazard.  (Without GPG installed they are not that much better,
5389     # though.)
5390     $fh = FileHandle->new;
5391     if (open($fh, $lc_want)) {
5392         my $line = <$fh>; close $fh;
5393         unlink($lc_want) unless $line =~ /PGP/;
5394     }
5395
5396     local($") = "/";
5397     # connect "force" argument with "index_expire".
5398     my $force = $self->{force};
5399     if (my @stat = stat $lc_want) {
5400         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5401     }
5402     my $lc_file;
5403     if ($may_ftp) {
5404         $lc_file = CPAN::FTP->localize(
5405                                        "authors/id/@$chksumfile",
5406                                        $lc_want,
5407                                        $force,
5408                                       );
5409         unless ($lc_file) {
5410             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5411             $chksumfile->[-1] .= ".gz";
5412             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5413                                            "$lc_want.gz",1);
5414             if ($lc_file) {
5415                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5416                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5417             } else {
5418                 return;
5419             }
5420         }
5421     } else {
5422         $lc_file = $lc_want;
5423         # we *could* second-guess and if the user has a file: URL,
5424         # then we could look there. But on the other hand, if they do
5425         # have a file: URL, wy did they choose to set
5426         # $CPAN::Config->{show_upload_date} to false?
5427     }
5428
5429     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5430     $fh = FileHandle->new;
5431     my($cksum);
5432     if (open $fh, $lc_file){
5433         local($/);
5434         my $eval = <$fh>;
5435         $eval =~ s/\015?\012/\n/g;
5436         close $fh;
5437         my($comp) = Safe->new();
5438         $cksum = $comp->reval($eval);
5439         if ($@) {
5440             rename $lc_file, "$lc_file.bad";
5441             Carp::confess($@) if $@;
5442         }
5443     } elsif ($may_ftp) {
5444         Carp::carp "Could not open '$lc_file' for reading.";
5445     } else {
5446         # Maybe should warn: "You may want to set show_upload_date to a true value"
5447         return;
5448     }
5449     my(@result,$f);
5450     for $f (sort keys %$cksum) {
5451         if (exists $cksum->{$f}{isdir}) {
5452             if ($recursive) {
5453                 my(@dir) = @$chksumfile;
5454                 pop @dir;
5455                 push @dir, $f, "CHECKSUMS";
5456                 push @result, map {
5457                     [$_->[0], $_->[1], "$f/$_->[2]"]
5458                 } $self->dir_listing(\@dir,1,$may_ftp);
5459             } else {
5460                 push @result, [ 0, "-", $f ];
5461             }
5462         } else {
5463             push @result, [
5464                            ($cksum->{$f}{"size"}||0),
5465                            $cksum->{$f}{"mtime"}||"---",
5466                            $f
5467                           ];
5468         }
5469     }
5470     @result;
5471 }
5472
5473 #-> sub CPAN::Author::reports
5474 sub reports {
5475     $CPAN::Frontend->mywarn("reports on authors not implemented.
5476 Please file a bugreport if you need this.\n");
5477 }
5478
5479 package CPAN::Distribution;
5480 use strict;
5481
5482 # Accessors
5483 sub cpan_comment {
5484     my $self = shift;
5485     my $ro = $self->ro or return;
5486     $ro->{CPAN_COMMENT}
5487 }
5488
5489 #-> CPAN::Distribution::undelay
5490 sub undelay {
5491     my $self = shift;
5492     delete $self->{later};
5493 }
5494
5495 #-> CPAN::Distribution::is_dot_dist
5496 sub is_dot_dist {
5497     my($self) = @_;
5498     return (
5499             substr($self->id,-1,1) eq "."
5500             ||
5501             $self->author->id eq "LOCAL"
5502            );
5503 }
5504
5505 # add the A/AN/ stuff
5506 #-> CPAN::Distribution::normalize
5507 sub normalize {
5508     my($self,$s) = @_;
5509     $s = $self->id unless defined $s;
5510     if (substr($s,-1,1) eq ".") {
5511         # using a global because we are sometimes called as static method
5512         if (!$CPAN::META->{LOCK}
5513             && !$CPAN::Have_warned->{"$s is unlocked"}++
5514            ) {
5515             $CPAN::Frontend->mywarn("You are visiting the local directory
5516   '$s'
5517   without lock, take care that concurrent processes do not do likewise.\n");
5518             $CPAN::Frontend->mysleep(1);
5519         }
5520         if ($s eq ".") {
5521             $s = "$CPAN::iCwd/.";
5522         } elsif (File::Spec->file_name_is_absolute($s)) {
5523         } elsif (File::Spec->can("rel2abs")) {
5524             $s = File::Spec->rel2abs($s);
5525         } else {
5526             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5527         }
5528         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5529         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5530             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5531                 $_->{build_dir} = $s;
5532                 $_->{archived} = "local_directory";
5533                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5534             }
5535         }
5536     } elsif (
5537         $s =~ tr|/|| == 1
5538         or
5539         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5540        ) {
5541         return $s if $s =~ m:^N/A|^Contact Author: ;
5542         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5543             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5544         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5545     }
5546     $s;
5547 }
5548
5549 #-> sub CPAN::Distribution::author ;
5550 sub author {
5551     my($self) = @_;
5552     my($authorid);
5553     if (substr($self->id,-1,1) eq ".") {
5554         $authorid = "LOCAL";
5555     } else {
5556         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5557     }
5558     CPAN::Shell->expand("Author",$authorid);
5559 }
5560
5561 # tries to get the yaml from CPAN instead of the distro itself:
5562 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5563 sub fast_yaml {
5564     my($self) = @_;
5565     my $meta = $self->pretty_id;
5566     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5567     my(@ls) = CPAN::Shell->globls($meta);
5568     my $norm = $self->normalize($meta);
5569
5570     my($local_file);
5571     my($local_wanted) =
5572         File::Spec->catfile(
5573                             $CPAN::Config->{keep_source_where},
5574                             "authors",
5575                             "id",
5576                             split(/\//,$norm)
5577                            );
5578     $self->debug("Doing localize") if $CPAN::DEBUG;
5579     unless ($local_file =
5580             CPAN::FTP->localize("authors/id/$norm",
5581                                 $local_wanted)) {
5582         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5583     }
5584     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5585 }
5586
5587 #-> sub CPAN::Distribution::cpan_userid
5588 sub cpan_userid {
5589     my $self = shift;
5590     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5591         return $1;
5592     }
5593     return $self->SUPER::cpan_userid;
5594 }
5595
5596 #-> sub CPAN::Distribution::pretty_id
5597 sub pretty_id {
5598     my $self = shift;
5599     my $id = $self->id;
5600     return $id unless $id =~ m|^./../|;
5601     substr($id,5);
5602 }
5603
5604 # mark as dirty/clean for the sake of recursion detection. $color=1
5605 # means "in use", $color=0 means "not in use anymore". $color=2 means
5606 # we have determined prereqs now and thus insist on passing this
5607 # through (at least) once again.
5608
5609 #-> sub CPAN::Distribution::color_cmd_tmps ;
5610 sub color_cmd_tmps {
5611     my($self) = shift;
5612     my($depth) = shift || 0;
5613     my($color) = shift || 0;
5614     my($ancestors) = shift || [];
5615     # a distribution needs to recurse into its prereq_pms
5616
5617     return if exists $self->{incommandcolor}
5618         && $color==1
5619         && $self->{incommandcolor}==$color;
5620     if ($depth>=$CPAN::MAX_RECURSION){
5621         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5622     }
5623     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5624     my $prereq_pm = $self->prereq_pm;
5625     if (defined $prereq_pm) {
5626       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5627                            keys %{$prereq_pm->{build_requires}||{}}) {
5628             next PREREQ if $pre eq "perl";
5629             my $premo;
5630             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5631                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5632                 $CPAN::Frontend->mysleep(2);
5633                 next PREREQ;
5634             }
5635             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5636         }
5637     }
5638     if ($color==0) {
5639         delete $self->{sponsored_mods};
5640
5641         # as we are at the end of a command, we'll give up this
5642         # reminder of a broken test. Other commands may test this guy
5643         # again. Maybe 'badtestcnt' should be renamed to
5644         # 'make_test_failed_within_command'?
5645         delete $self->{badtestcnt};
5646     }
5647     $self->{incommandcolor} = $color;
5648 }
5649
5650 #-> sub CPAN::Distribution::as_string ;
5651 sub as_string {
5652   my $self = shift;
5653   $self->containsmods;
5654   $self->upload_date;
5655   $self->SUPER::as_string(@_);
5656 }
5657
5658 #-> sub CPAN::Distribution::containsmods ;
5659 sub containsmods {
5660   my $self = shift;
5661   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5662   my $dist_id = $self->{ID};
5663   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5664     my $mod_file = $mod->cpan_file or next;
5665     my $mod_id = $mod->{ID} or next;
5666     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5667     # sleep 1;
5668     if ($CPAN::Signal) {
5669         delete $self->{CONTAINSMODS};
5670         return;
5671     }
5672     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5673   }
5674   keys %{$self->{CONTAINSMODS}||{}};
5675 }
5676
5677 #-> sub CPAN::Distribution::upload_date ;
5678 sub upload_date {
5679   my $self = shift;
5680   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5681   my(@local_wanted) = split(/\//,$self->id);
5682   my $filename = pop @local_wanted;
5683   push @local_wanted, "CHECKSUMS";
5684   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5685   return unless $author;
5686   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5687   return unless @dl;
5688   my($dirent) = grep { $_->[2] eq $filename } @dl;
5689   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5690   return unless $dirent->[1];
5691   return $self->{UPLOAD_DATE} = $dirent->[1];
5692 }
5693
5694 #-> sub CPAN::Distribution::uptodate ;
5695 sub uptodate {
5696     my($self) = @_;
5697     my $c;
5698     foreach $c ($self->containsmods) {
5699         my $obj = CPAN::Shell->expandany($c);
5700         unless ($obj->uptodate){
5701             my $id = $self->pretty_id;
5702             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5703             return 0;
5704         }
5705     }
5706     return 1;
5707 }
5708
5709 #-> sub CPAN::Distribution::called_for ;
5710 sub called_for {
5711     my($self,$id) = @_;
5712     $self->{CALLED_FOR} = $id if defined $id;
5713     return $self->{CALLED_FOR};
5714 }
5715
5716 #-> sub CPAN::Distribution::get ;
5717 sub get {
5718     my($self) = @_;
5719     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5720     if (my $goto = $self->prefs->{goto}) {
5721         $CPAN::Frontend->mywarn
5722             (sprintf(
5723                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5724                      $goto,
5725                      $self->{prefs_file},
5726                      $self->{prefs_file_doc},
5727                     ));
5728         return $self->goto($goto);
5729     }
5730     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5731                            ? $ENV{PERL5LIB}
5732                            : ($ENV{PERLLIB} || "");
5733
5734     $CPAN::META->set_perl5lib;
5735     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5736
5737   EXCUSE: {
5738         my @e;
5739         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5740         if ($self->prefs->{disabled}) {
5741             my $why = sprintf(
5742                               "Disabled via prefs file '%s' doc %d",
5743                               $self->{prefs_file},
5744                               $self->{prefs_file_doc},
5745                              );
5746             push @e, $why;
5747             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5748             # note: not intended to be persistent but at least visible
5749             # during this session
5750         } else {
5751             if (exists $self->{build_dir} && -d $self->{build_dir}
5752                 && ($self->{modulebuild}||$self->{writemakefile})
5753                ) {
5754                 # this deserves print, not warn:
5755                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5756                                          "$self->{build_dir}\n"
5757                                         );
5758                 return 1;
5759             }
5760
5761             # although we talk about 'force' we shall not test on
5762             # force directly. New model of force tries to refrain from
5763             # direct checking of force.
5764             exists $self->{unwrapped} and (
5765                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5766                                            $self->{unwrapped}->failed :
5767                                            $self->{unwrapped} =~ /^NO/
5768                                           )
5769                 and push @e, "Unwrapping had some problem, won't try again without force";
5770         }
5771
5772         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5773     }
5774     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5775
5776     $self->get_file_onto_local_disk;
5777     return if $CPAN::Signal;
5778     $self->check_integrity;
5779     return if $CPAN::Signal;
5780     my($packagedir,$local_file) = $self->run_preps_on_packagedir;
5781     $packagedir ||= $self->{build_dir};
5782
5783     if ($CPAN::Signal){
5784         $self->safe_chdir($sub_wd);
5785         return;
5786     }
5787     return $self->run_MM_or_MB($local_file,$packagedir);
5788 }
5789
5790 #-> CPAN::Distribution::get_file_onto_local_disk
5791 sub get_file_onto_local_disk {
5792     my($self) = @_;
5793
5794     return if $self->is_dot_dist;
5795     my($local_file);
5796     my($local_wanted) =
5797         File::Spec->catfile(
5798                             $CPAN::Config->{keep_source_where},
5799                             "authors",
5800                             "id",
5801                             split(/\//,$self->id)
5802                            );
5803
5804     $self->debug("Doing localize") if $CPAN::DEBUG;
5805     unless ($local_file =
5806             CPAN::FTP->localize("authors/id/$self->{ID}",
5807                                 $local_wanted)) {
5808         my $note = "";
5809         if ($CPAN::Index::DATE_OF_02) {
5810             $note = "Note: Current database in memory was generated ".
5811                 "on $CPAN::Index::DATE_OF_02\n";
5812         }
5813         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5814     }
5815
5816     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5817     $self->{localfile} = $local_file;
5818 }
5819
5820
5821 #-> CPAN::Distribution::check_integrity
5822 sub check_integrity {
5823     my($self) = @_;
5824
5825     return if $self->is_dot_dist;
5826     if ($CPAN::META->has_inst("Digest::SHA")) {
5827         $self->debug("Digest::SHA is installed, verifying");
5828         $self->verifyCHECKSUM;
5829     } else {
5830         $self->debug("Digest::SHA is NOT installed");
5831     }
5832 }
5833
5834 #-> CPAN::Distribution::run_preps_on_packagedir
5835 sub run_preps_on_packagedir {
5836     my($self) = @_;
5837     return if $self->is_dot_dist;
5838
5839     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5840     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5841     $self->safe_chdir($builddir);
5842     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5843     File::Path::rmtree("tmp-$$");
5844     unless (mkdir "tmp-$$", 0755) {
5845         $CPAN::Frontend->unrecoverable_error(<<EOF);
5846 Couldn't mkdir '$builddir/tmp-$$': $!
5847
5848 Cannot continue: Please find the reason why I cannot make the
5849 directory
5850 $builddir/tmp-$$
5851 and fix the problem, then retry.
5852
5853 EOF
5854     }
5855     if ($CPAN::Signal){
5856         return;
5857     }
5858     $self->safe_chdir("tmp-$$");
5859
5860     #
5861     # Unpack the goods
5862     #
5863     my $local_file = $self->{localfile};
5864     my $ct = eval{CPAN::Tarzip->new($local_file)};
5865     unless ($ct) {
5866         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5867         delete $self->{build_dir};
5868         return;
5869     }
5870     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5871         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5872         $self->untar_me($ct);
5873     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5874         $self->unzip_me($ct);
5875     } else {
5876         $self->{was_uncompressed}++ unless $ct->gtest();
5877         $local_file = $self->handle_singlefile($local_file);
5878     }
5879
5880     # we are still in the tmp directory!
5881     # Let's check if the package has its own directory.
5882     my $dh = DirHandle->new(File::Spec->curdir)
5883         or Carp::croak("Couldn't opendir .: $!");
5884     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5885     $dh->close;
5886     my ($packagedir);
5887     # XXX here we want in each branch File::Temp to protect all build_dir directories
5888     if (CPAN->has_inst("File::Temp")) {
5889         my $tdir_base;
5890         my $from_dir;
5891         my @dirents;
5892         if (@readdir == 1 && -d $readdir[0]) {
5893             $tdir_base = $readdir[0];
5894             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5895             my $dh2 = DirHandle->new($from_dir)
5896                 or Carp::croak("Couldn't opendir $from_dir: $!");
5897             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5898         } else {
5899             my $userid = $self->cpan_userid;
5900             CPAN->debug("userid[$userid]");
5901             if (!$userid or $userid eq "N/A") {
5902                 $userid = "anon";
5903             }
5904             $tdir_base = $userid;
5905             $from_dir = File::Spec->curdir;
5906             @dirents = @readdir;
5907         }
5908         $packagedir = File::Temp::tempdir(
5909                                           "$tdir_base-XXXXXX",
5910                                           DIR => $builddir,
5911                                           CLEANUP => 0,
5912                                          );
5913         my $f;
5914         for $f (@dirents) { # is already without "." and ".."
5915             my $from = File::Spec->catdir($from_dir,$f);
5916             my $to = File::Spec->catdir($packagedir,$f);
5917             unless (File::Copy::move($from,$to)) {
5918                 my $err = $!;
5919                 $from = File::Spec->rel2abs($from);
5920                 Carp::confess("Couldn't move $from to $to: $err");
5921             }
5922         }
5923     } else { # older code below, still better than nothing when there is no File::Temp
5924         my($distdir);
5925         if (@readdir == 1 && -d $readdir[0]) {
5926             $distdir = $readdir[0];
5927             $packagedir = File::Spec->catdir($builddir,$distdir);
5928             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5929                 if $CPAN::DEBUG;
5930             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5931                                                         "$packagedir\n");
5932             File::Path::rmtree($packagedir);
5933             unless (File::Copy::move($distdir,$packagedir)) {
5934                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5935 Couldn't move '$distdir' to '$packagedir': $!
5936
5937 Cannot continue: Please find the reason why I cannot move
5938 $builddir/tmp-$$/$distdir
5939 to
5940 $packagedir
5941 and fix the problem, then retry
5942
5943 EOF
5944             }
5945             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5946                                  $distdir,
5947                                  $packagedir,
5948                                  -e $packagedir,
5949                                  -d $packagedir,
5950                                 )) if $CPAN::DEBUG;
5951         } else {
5952             my $userid = $self->cpan_userid;
5953             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5954             if (!$userid or $userid eq "N/A") {
5955                 $userid = "anon";
5956             }
5957             my $pragmatic_dir = $userid . '000';
5958             $pragmatic_dir =~ s/\W_//g;
5959             $pragmatic_dir++ while -d "../$pragmatic_dir";
5960             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5961             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5962             File::Path::mkpath($packagedir);
5963             my($f);
5964             for $f (@readdir) { # is already without "." and ".."
5965                 my $to = File::Spec->catdir($packagedir,$f);
5966                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5967             }
5968         }
5969     }
5970     $self->{build_dir} = $packagedir;
5971     $self->safe_chdir($builddir);
5972     File::Path::rmtree("tmp-$$");
5973
5974     $self->safe_chdir($packagedir);
5975     $self->_signature_business();
5976     $self->safe_chdir($builddir);
5977
5978     return($packagedir,$local_file);
5979 }
5980
5981 #-> sub CPAN::Distribution::run_MM_or_MB
5982 sub run_MM_or_MB {
5983     my($self,$local_file,$packagedir) = @_;
5984     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5985     my($mpl_exists) = -f $mpl;
5986     unless ($mpl_exists) {
5987         # NFS has been reported to have racing problems after the
5988         # renaming of a directory in some environments.
5989         # This trick helps.
5990         $CPAN::Frontend->mysleep(1);
5991         my $mpldh = DirHandle->new($packagedir)
5992             or Carp::croak("Couldn't opendir $packagedir: $!");
5993         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5994         $mpldh->close;
5995     }
5996     my $prefer_installer = "eumm"; # eumm|mb
5997     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5998         if ($mpl_exists) { # they *can* choose
5999             if ($CPAN::META->has_inst("Module::Build")) {
6000                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6001                                                                      q{prefer_installer});
6002             }
6003         } else {
6004             $prefer_installer = "mb";
6005         }
6006     }
6007     return unless $self->patch;
6008     if (lc($prefer_installer) eq "mb") {
6009         $self->{modulebuild} = 1;
6010     } elsif ($self->{archived} eq "patch") {
6011         # not an edge case, nothing to install for sure
6012         my $why = "A patch file cannot be installed";
6013         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6014         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6015     } elsif (! $mpl_exists) {
6016         $self->_edge_cases($mpl,$packagedir,$local_file);
6017     }
6018     if ($self->{build_dir}
6019         &&
6020         $CPAN::Config->{build_dir_reuse}
6021        ) {
6022         $self->store_persistent_state;
6023     }
6024     return $self;
6025 }
6026
6027 #-> CPAN::Distribution::store_persistent_state
6028 sub store_persistent_state {
6029     my($self) = @_;
6030     my $dir = $self->{build_dir};
6031     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6032             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6033         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6034                                 "will not store persistent state\n");
6035         return;
6036     }
6037     my $file = sprintf "%s.yml", $dir;
6038     my $yaml_module = CPAN::_yaml_module;
6039     if ($CPAN::META->has_inst($yaml_module)) {
6040         CPAN->_yaml_dumpfile(
6041                              $file,
6042                              {
6043                               time => time,
6044                               perl => CPAN::_perl_fingerprint,
6045                               distribution => $self,
6046                              }
6047                             );
6048     } else {
6049         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6050                                 "will not store persistent state\n");
6051     }
6052 }
6053
6054 #-> CPAN::Distribution::patch
6055 sub try_download {
6056     my($self,$patch) = @_;
6057     my $norm = $self->normalize($patch);
6058     my($local_wanted) =
6059         File::Spec->catfile(
6060                             $CPAN::Config->{keep_source_where},
6061                             "authors",
6062                             "id",
6063                             split(/\//,$norm),
6064                             );
6065     $self->debug("Doing localize") if $CPAN::DEBUG;
6066     return CPAN::FTP->localize("authors/id/$norm",
6067                                $local_wanted);
6068 }
6069
6070 #-> CPAN::Distribution::patch
6071 sub patch {
6072     my($self) = @_;
6073     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6074     my $patches = $self->prefs->{patches};
6075     $patches ||= "";
6076     $self->debug("patches[$patches]") if $CPAN::DEBUG;
6077     if ($patches) {
6078         return unless @$patches;
6079         $self->safe_chdir($self->{build_dir});
6080         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6081         my $patchbin = $CPAN::Config->{patch};
6082         unless ($patchbin && length $patchbin) {
6083             $CPAN::Frontend->mydie("No external patch command configured\n\n".
6084                                    "Please run 'o conf init /patch/'\n\n");
6085         }
6086         unless (MM->maybe_command($patchbin)) {
6087             $CPAN::Frontend->mydie("No external patch command available\n\n".
6088                                    "Please run 'o conf init /patch/'\n\n");
6089         }
6090         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6091         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
6092                                    # supported everywhere (and then,
6093                                    # not ever necessary there)
6094         my $stdpatchargs = "-N --fuzz=3";
6095         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6096         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6097         for my $patch (@$patches) {
6098             unless (-f $patch) {
6099                 if (my $trydl = $self->try_download($patch)) {
6100                     $patch = $trydl;
6101                 } else {
6102                     my $fail = "Could not find patch '$patch'";
6103                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6104                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6105                     delete $self->{build_dir};
6106                     return;
6107                 }
6108             }
6109             $CPAN::Frontend->myprint("  $patch\n");
6110             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6111
6112             my $pcommand;
6113             my $ppp = $self->_patch_p_parameter($readfh);
6114             if ($ppp eq "applypatch") {
6115                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6116             } else {
6117                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6118                 $pcommand = "$patchbin $thispatchargs";
6119             }
6120
6121             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6122             my $writefh = FileHandle->new;
6123             $CPAN::Frontend->myprint("  $pcommand\n");
6124             unless (open $writefh, "|$pcommand") {
6125                 my $fail = "Could not fork '$pcommand'";
6126                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6127                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6128                 delete $self->{build_dir};
6129                 return;
6130             }
6131             while (my $x = $readfh->READLINE) {
6132                 print $writefh $x;
6133             }
6134             unless (close $writefh) {
6135                 my $fail = "Could not apply patch '$patch'";
6136                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6137                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6138                 delete $self->{build_dir};
6139                 return;
6140             }
6141         }
6142         $self->{patched}++;
6143     }
6144     return 1;
6145 }
6146
6147 sub _patch_p_parameter {
6148     my($self,$fh) = @_;
6149     my $cnt_files   = 0;
6150     my $cnt_p0files = 0;
6151     local($_);
6152     while ($_ = $fh->READLINE) {
6153         if (
6154             $CPAN::Config->{applypatch}
6155             &&
6156             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6157            ) {
6158             return "applypatch"
6159         }
6160         next unless /^[\*\+]{3}\s(\S+)/;
6161         my $file = $1;
6162         $cnt_files++;
6163         $cnt_p0files++ if -f $file;
6164         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6165             if $CPAN::DEBUG;
6166     }
6167     return "-p1" unless $cnt_files;
6168     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6169 }
6170
6171 #-> sub CPAN::Distribution::_edge_cases
6172 # with "configure" or "Makefile" or single file scripts
6173 sub _edge_cases {
6174     my($self,$mpl,$packagedir,$local_file) = @_;
6175     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6176                          $mpl,
6177                          CPAN::anycwd(),
6178                         )) if $CPAN::DEBUG;
6179     my($configure) = File::Spec->catfile($packagedir,"Configure");
6180     if (-f $configure) {
6181         # do we have anything to do?
6182         $self->{configure} = $configure;
6183     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6184         $CPAN::Frontend->mywarn(qq{
6185 Package comes with a Makefile and without a Makefile.PL.
6186 We\'ll try to build it with that Makefile then.
6187 });
6188         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6189         $CPAN::Frontend->mysleep(2);
6190     } else {
6191         my $cf = $self->called_for || "unknown";
6192         if ($cf =~ m|/|) {
6193             $cf =~ s|.*/||;
6194             $cf =~ s|\W.*||;
6195         }
6196         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6197         $cf = "unknown" unless length($cf);
6198         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6199   (The test -f "$mpl" returned false.)
6200   Writing one on our own (setting NAME to $cf)\a\n});
6201         $self->{had_no_makefile_pl}++;
6202         $CPAN::Frontend->mysleep(3);
6203
6204         # Writing our own Makefile.PL
6205
6206         my $script = "";
6207         if ($self->{archived} eq "maybe_pl") {
6208             my $fh = FileHandle->new;
6209             my $script_file = File::Spec->catfile($packagedir,$local_file);
6210             $fh->open($script_file)
6211                 or Carp::croak("Could not open script '$script_file': $!");
6212             local $/ = "\n";
6213             # name parsen und prereq
6214             my($state) = "poddir";
6215             my($name, $prereq) = ("", "");
6216             while (<$fh>) {
6217                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6218                     if ($1 eq 'NAME') {
6219                         $state = "name";
6220                     } elsif ($1 eq 'PREREQUISITES') {
6221                         $state = "prereq";
6222                     }
6223                 } elsif ($state =~ m{^(name|prereq)$}) {
6224                     if (/^=/) {
6225                         $state = "poddir";
6226                     } elsif (/^\s*$/) {
6227                         # nop
6228                     } elsif ($state eq "name") {
6229                         if ($name eq "") {
6230                             ($name) = /^(\S+)/;
6231                             $state = "poddir";
6232                         }
6233                     } elsif ($state eq "prereq") {
6234                         $prereq .= $_;
6235                     }
6236                 } elsif (/^=cut\b/) {
6237                     last;
6238                 }
6239             }
6240             $fh->close;
6241
6242             for ($name) {
6243                 s{.*<}{};       # strip X<...>
6244                 s{>.*}{};
6245             }
6246             chomp $prereq;
6247             $prereq = join " ", split /\s+/, $prereq;
6248             my($PREREQ_PM) = join("\n", map {
6249                 s{.*<}{};       # strip X<...>
6250                 s{>.*}{};
6251                 if (/[\s\'\"]/) { # prose?
6252                 } else {
6253                     s/[^\w:]$//; # period?
6254                     " "x28 . "'$_' => 0,";
6255                 }
6256             } split /\s*,\s*/, $prereq);
6257
6258             $script = "
6259               EXE_FILES => ['$name'],
6260               PREREQ_PM => {
6261 $PREREQ_PM
6262                            },
6263 ";
6264             if ($name) {
6265                 my $to_file = File::Spec->catfile($packagedir, $name);
6266                 rename $script_file, $to_file
6267                     or die "Can't rename $script_file to $to_file: $!";
6268             }
6269         }
6270
6271         my $fh = FileHandle->new;
6272         $fh->open(">$mpl")
6273             or Carp::croak("Could not open >$mpl: $!");
6274         $fh->print(
6275                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6276 # because there was no Makefile.PL supplied.
6277 # Autogenerated on: }.scalar localtime().qq{
6278
6279 use ExtUtils::MakeMaker;
6280 WriteMakefile(
6281               NAME => q[$cf],$script
6282              );
6283 });
6284         $fh->close;
6285     }
6286 }
6287
6288 #-> CPAN::Distribution::_signature_business
6289 sub _signature_business {
6290     my($self) = @_;
6291     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6292                                                       q{check_sigs});
6293     if ($check_sigs) {
6294         if ($CPAN::META->has_inst("Module::Signature")) {
6295             if (-f "SIGNATURE") {
6296                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6297                 my $rv = Module::Signature::verify();
6298                 if ($rv != Module::Signature::SIGNATURE_OK() and
6299                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6300                     $CPAN::Frontend->mywarn(
6301                                             qq{\nSignature invalid for }.
6302                                             qq{distribution file. }.
6303                                             qq{Please investigate.\n\n}
6304                                            );
6305
6306                     my $wrap =
6307                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6308                                 qq{while checking its signature, so it could        }.
6309                                 qq{be invalid. Maybe you have configured            }.
6310                                 qq{your 'urllist' with a bad URL. Please check this }.
6311                                 qq{array with 'o conf urllist' and retry. Or        }.
6312                                 qq{examine the distribution in a subshell. Try
6313   look %s
6314 and run
6315   cpansign -v
6316 },
6317                                 $self->{localfile},
6318                                 $self->pretty_id,
6319                                );
6320                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6321                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6322                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6323                 } else {
6324                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6325                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6326                 }
6327             } else {
6328                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6329             }
6330         } else {
6331             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6332         }
6333     }
6334 }
6335
6336 #-> CPAN::Distribution::untar_me ;
6337 sub untar_me {
6338     my($self,$ct) = @_;
6339     $self->{archived} = "tar";
6340     if ($ct->untar()) {
6341         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6342     } else {
6343         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6344     }
6345 }
6346
6347 # CPAN::Distribution::unzip_me ;
6348 sub unzip_me {
6349     my($self,$ct) = @_;
6350     $self->{archived} = "zip";
6351     if ($ct->unzip()) {
6352         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6353     } else {
6354         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6355     }
6356     return;
6357 }
6358
6359 sub handle_singlefile {
6360     my($self,$local_file) = @_;
6361
6362     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6363         $self->{archived} = "pm";
6364     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6365         $self->{archived} = "patch";
6366     } else {
6367         $self->{archived} = "maybe_pl";
6368     }
6369
6370     my $to = File::Basename::basename($local_file);
6371     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6372         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6373             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6374         } else {
6375             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6376         }
6377     } else {
6378         if (File::Copy::cp($local_file,".")) {
6379             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6380         } else {
6381             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6382         }
6383     }
6384     return $to;
6385 }
6386
6387 #-> sub CPAN::Distribution::new ;
6388 sub new {
6389     my($class,%att) = @_;
6390
6391     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6392
6393     my $this = { %att };
6394     return bless $this, $class;
6395 }
6396
6397 #-> sub CPAN::Distribution::look ;
6398 sub look {
6399     my($self) = @_;
6400
6401     if ($^O eq 'MacOS') {
6402       $self->Mac::BuildTools::look;
6403       return;
6404     }
6405
6406     if (  $CPAN::Config->{'shell'} ) {
6407         $CPAN::Frontend->myprint(qq{
6408 Trying to open a subshell in the build directory...
6409 });
6410     } else {
6411         $CPAN::Frontend->myprint(qq{
6412 Your configuration does not define a value for subshells.
6413 Please define it with "o conf shell <your shell>"
6414 });
6415         return;
6416     }
6417     my $dist = $self->id;
6418     my $dir;
6419     unless ($dir = $self->dir) {
6420         $self->get;
6421     }
6422     unless ($dir ||= $self->dir) {
6423         $CPAN::Frontend->mywarn(qq{
6424 Could not determine which directory to use for looking at $dist.
6425 });
6426         return;
6427     }
6428     my $pwd  = CPAN::anycwd();
6429     $self->safe_chdir($dir);
6430     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6431     {
6432         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6433         $ENV{CPAN_SHELL_LEVEL} += 1;
6434         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6435         unless (system($shell) == 0) {
6436             my $code = $? >> 8;
6437             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6438         }
6439     }
6440     $self->safe_chdir($pwd);
6441 }
6442
6443 # CPAN::Distribution::cvs_import ;
6444 sub cvs_import {
6445     my($self) = @_;
6446     $self->get;
6447     my $dir = $self->dir;
6448
6449     my $package = $self->called_for;
6450     my $module = $CPAN::META->instance('CPAN::Module', $package);
6451     my $version = $module->cpan_version;
6452
6453     my $userid = $self->cpan_userid;
6454
6455     my $cvs_dir = (split /\//, $dir)[-1];
6456     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6457     my $cvs_root =
6458       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6459     my $cvs_site_perl =
6460       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6461     if ($cvs_site_perl) {
6462         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6463     }
6464     my $cvs_log = qq{"imported $package $version sources"};
6465     $version =~ s/\./_/g;
6466     # XXX cvs: undocumented and unclear how it was meant to work
6467     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6468                "$cvs_dir", $userid, "v$version");
6469
6470     my $pwd  = CPAN::anycwd();
6471     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6472
6473     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6474
6475     $CPAN::Frontend->myprint(qq{@cmd\n});
6476     system(@cmd) == 0 or
6477     # XXX cvs
6478         $CPAN::Frontend->mydie("cvs import failed");
6479     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6480 }
6481
6482 #-> sub CPAN::Distribution::readme ;
6483 sub readme {
6484     my($self) = @_;
6485     my($dist) = $self->id;
6486     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6487     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6488     my($local_file);
6489     my($local_wanted) =
6490          File::Spec->catfile(
6491                              $CPAN::Config->{keep_source_where},
6492                              "authors",
6493                              "id",
6494                              split(/\//,"$sans.readme"),
6495                             );
6496     $self->debug("Doing localize") if $CPAN::DEBUG;
6497     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6498                                       $local_wanted)
6499         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6500
6501     if ($^O eq 'MacOS') {
6502         Mac::BuildTools::launch_file($local_file);
6503         return;
6504     }
6505
6506     my $fh_pager = FileHandle->new;
6507     local($SIG{PIPE}) = "IGNORE";
6508     my $pager = $CPAN::Config->{'pager'} || "cat";
6509     $fh_pager->open("|$pager")
6510         or die "Could not open pager $pager\: $!";
6511     my $fh_readme = FileHandle->new;
6512     $fh_readme->open($local_file)
6513         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6514     $CPAN::Frontend->myprint(qq{
6515 Displaying file
6516   $local_file
6517 with pager "$pager"
6518 });
6519     $fh_pager->print(<$fh_readme>);
6520     $fh_pager->close;
6521 }
6522
6523 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6524 sub verifyCHECKSUM {
6525     my($self) = @_;
6526   EXCUSE: {
6527         my @e;
6528         $self->{CHECKSUM_STATUS} ||= "";
6529         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6530         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6531     }
6532     my($lc_want,$lc_file,@local,$basename);
6533     @local = split(/\//,$self->id);
6534     pop @local;
6535     push @local, "CHECKSUMS";
6536     $lc_want =
6537         File::Spec->catfile($CPAN::Config->{keep_source_where},
6538                             "authors", "id", @local);
6539     local($") = "/";
6540     if (my $size = -s $lc_want) {
6541         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6542         if ($self->CHECKSUM_check_file($lc_want,1)) {
6543             return $self->{CHECKSUM_STATUS} = "OK";
6544         }
6545     }
6546     $lc_file = CPAN::FTP->localize("authors/id/@local",
6547                                    $lc_want,1);
6548     unless ($lc_file) {
6549         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6550         $local[-1] .= ".gz";
6551         $lc_file = CPAN::FTP->localize("authors/id/@local",
6552                                        "$lc_want.gz",1);
6553         if ($lc_file) {
6554             $lc_file =~ s/\.gz(?!\n)\Z//;
6555             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6556         } else {
6557             return;
6558         }
6559     }
6560     if ($self->CHECKSUM_check_file($lc_file)) {
6561         return $self->{CHECKSUM_STATUS} = "OK";
6562     }
6563 }
6564
6565 #-> sub CPAN::Distribution::SIG_check_file ;
6566 sub SIG_check_file {
6567     my($self,$chk_file) = @_;
6568     my $rv = eval { Module::Signature::_verify($chk_file) };
6569
6570     if ($rv == Module::Signature::SIGNATURE_OK()) {
6571         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6572         return $self->{SIG_STATUS} = "OK";
6573     } else {
6574         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6575                                  qq{distribution file. }.
6576                                  qq{Please investigate.\n\n}.
6577                                  $self->as_string,
6578                                 $CPAN::META->instance(
6579                                                         'CPAN::Author',
6580                                                         $self->cpan_userid
6581                                                         )->as_string);
6582
6583         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6584 is invalid. Maybe you have configured your 'urllist' with
6585 a bad URL. Please check this array with 'o conf urllist', and
6586 retry.};
6587
6588         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6589     }
6590 }
6591
6592 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6593
6594 # sloppy is 1 when we have an old checksums file that maybe is good
6595 # enough
6596
6597 sub CHECKSUM_check_file {
6598     my($self,$chk_file,$sloppy) = @_;
6599     my($cksum,$file,$basename);
6600
6601     $sloppy ||= 0;
6602     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6603     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6604                                                       q{check_sigs});
6605     if ($check_sigs) {
6606         if ($CPAN::META->has_inst("Module::Signature")) {
6607             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6608             $self->SIG_check_file($chk_file);
6609         } else {
6610             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6611         }
6612     }
6613
6614     $file = $self->{localfile};
6615     $basename = File::Basename::basename($file);
6616     my $fh = FileHandle->new;
6617     if (open $fh, $chk_file){
6618         local($/);
6619         my $eval = <$fh>;
6620         $eval =~ s/\015?\012/\n/g;
6621         close $fh;
6622         my($comp) = Safe->new();
6623         $cksum = $comp->reval($eval);
6624         if ($@) {
6625             rename $chk_file, "$chk_file.bad";
6626             Carp::confess($@) if $@;
6627         }
6628     } else {
6629         Carp::carp "Could not open $chk_file for reading";
6630     }
6631
6632     if (! ref $cksum or ref $cksum ne "HASH") {
6633         $CPAN::Frontend->mywarn(qq{
6634 Warning: checksum file '$chk_file' broken.
6635
6636 When trying to read that file I expected to get a hash reference
6637 for further processing, but got garbage instead.
6638 });
6639         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6640         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6641         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6642         return;
6643     } elsif (exists $cksum->{$basename}{sha256}) {
6644         $self->debug("Found checksum for $basename:" .
6645                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6646
6647         open($fh, $file);
6648         binmode $fh;
6649         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6650         $fh->close;
6651         $fh = CPAN::Tarzip->TIEHANDLE($file);
6652
6653         unless ($eq) {
6654           my $dg = Digest::SHA->new(256);
6655           my($data,$ref);
6656           $ref = \$data;
6657           while ($fh->READ($ref, 4096) > 0){
6658             $dg->add($data);
6659           }
6660           my $hexdigest = $dg->hexdigest;
6661           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6662         }
6663
6664         if ($eq) {
6665           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6666           return $self->{CHECKSUM_STATUS} = "OK";
6667         } else {
6668             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6669                                      qq{distribution file. }.
6670                                      qq{Please investigate.\n\n}.
6671                                      $self->as_string,
6672                                      $CPAN::META->instance(
6673                                                            'CPAN::Author',
6674                                                            $self->cpan_userid
6675                                                           )->as_string);
6676
6677             my $wrap = qq{I\'d recommend removing $file. Its
6678 checksum is incorrect. Maybe you have configured your 'urllist' with
6679 a bad URL. Please check this array with 'o conf urllist', and
6680 retry.};
6681
6682             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6683
6684             # former versions just returned here but this seems a
6685             # serious threat that deserves a die
6686
6687             # $CPAN::Frontend->myprint("\n\n");
6688             # sleep 3;
6689             # return;
6690         }
6691         # close $fh if fileno($fh);
6692     } else {
6693         return if $sloppy;
6694         unless ($self->{CHECKSUM_STATUS}) {
6695             $CPAN::Frontend->mywarn(qq{
6696 Warning: No checksum for $basename in $chk_file.
6697
6698 The cause for this may be that the file is very new and the checksum
6699 has not yet been calculated, but it may also be that something is
6700 going awry right now.
6701 });
6702             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6703             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6704         }
6705         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6706         return;
6707     }
6708 }
6709
6710 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6711 sub eq_CHECKSUM {
6712     my($self,$fh,$expect) = @_;
6713     if ($CPAN::META->has_inst("Digest::SHA")) {
6714         my $dg = Digest::SHA->new(256);
6715         my($data);
6716         while (read($fh, $data, 4096)){
6717             $dg->add($data);
6718         }
6719         my $hexdigest = $dg->hexdigest;
6720         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6721         return $hexdigest eq $expect;
6722     }
6723     return 1;
6724 }
6725
6726 #-> sub CPAN::Distribution::force ;
6727
6728 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6729 # effect by autoinspection, not by inspecting a global variable. One
6730 # of the reason why this was chosen to work that way was the treatment
6731 # of dependencies. They should not automatically inherit the force
6732 # status. But this has the downside that ^C and die() will return to
6733 # the prompt but will not be able to reset the force_update
6734 # attributes. We try to correct for it currently in the read_metadata
6735 # routine, and immediately before we check for a Signal. I hope this
6736 # works out in one of v1.57_53ff
6737
6738 # "Force get forgets previous error conditions"
6739
6740 #-> sub CPAN::Distribution::fforce ;
6741 sub fforce {
6742   my($self, $method) = @_;
6743   $self->force($method,1);
6744 }
6745
6746 #-> sub CPAN::Distribution::force ;
6747 sub force {
6748   my($self, $method,$fforce) = @_;
6749   my %phase_map = (
6750                    get => [
6751                            "unwrapped",
6752                            "build_dir",
6753                            "archived",
6754                            "localfile",
6755                            "CHECKSUM_STATUS",
6756                            "signature_verify",
6757                            "prefs",
6758                            "prefs_file",
6759                            "prefs_file_doc",
6760                           ],
6761                    make => [
6762                             "writemakefile",
6763                             "make",
6764                             "modulebuild",
6765                             "prereq_pm",
6766                             "prereq_pm_detected",
6767                            ],
6768                    test => [
6769                             "badtestcnt",
6770                             "make_test",
6771                            ],
6772                    install => [
6773                                "install",
6774                               ],
6775                    unknown => [
6776                                "reqtype",
6777                                "yaml_content",
6778                               ],
6779                   );
6780   my $methodmatch = 0;
6781   my $ldebug = 0;
6782  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6783       $methodmatch = 1 if $fforce || $phase eq $method;
6784       next unless $methodmatch;
6785     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6786           if ($phase eq "get") {
6787               if (substr($self->id,-1,1) eq "."
6788                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6789                   # cannot be undone for local distros
6790                   next ATTRIBUTE;
6791               }
6792               if ($att eq "build_dir"
6793                   && $self->{build_dir}
6794                   && $CPAN::META->{is_tested}
6795                  ) {
6796                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6797               }
6798           } elsif ($phase eq "test") {
6799               if ($att eq "make_test"
6800                   && $self->{make_test}
6801                   && $self->{make_test}{COMMANDID}
6802                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6803                  ) {
6804                   # endless loop too likely
6805                   next ATTRIBUTE;
6806               }
6807           }
6808           delete $self->{$att};
6809           if ($ldebug || $CPAN::DEBUG) {
6810               # local $CPAN::DEBUG = 16; # Distribution
6811               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6812           }
6813       }
6814   }
6815   if ($method && $method =~ /make|test|install/) {
6816     $self->{force_update} = 1; # name should probably have been force_install
6817   }
6818 }
6819
6820 #-> sub CPAN::Distribution::notest ;
6821 sub notest {
6822   my($self, $method) = @_;
6823   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
6824   $self->{"notest"}++; # name should probably have been force_install
6825 }
6826
6827 #-> sub CPAN::Distribution::unnotest ;
6828 sub unnotest {
6829   my($self) = @_;
6830   # warn "XDEBUG: deleting notest";
6831   delete $self->{notest};
6832 }
6833
6834 #-> sub CPAN::Distribution::unforce ;
6835 sub unforce {
6836   my($self) = @_;
6837   delete $self->{force_update};
6838 }
6839
6840 #-> sub CPAN::Distribution::isa_perl ;
6841 sub isa_perl {
6842   my($self) = @_;
6843   my $file = File::Basename::basename($self->id);
6844   if ($file =~ m{ ^ perl
6845                   -?
6846                   (5)
6847                   ([._-])
6848                   (
6849                    \d{3}(_[0-4][0-9])?
6850                    |
6851                    \d+\.\d+
6852                   )
6853                   \.tar[._-](?:gz|bz2)
6854                   (?!\n)\Z
6855                 }xs){
6856     return "$1.$3";
6857   } elsif ($self->cpan_comment
6858            &&
6859            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6860     return $1;
6861   }
6862 }
6863
6864
6865 #-> sub CPAN::Distribution::perl ;
6866 sub perl {
6867     my ($self) = @_;
6868     if (! $self) {
6869         use Carp qw(carp);
6870         carp __PACKAGE__ . "::perl was called without parameters.";
6871     }
6872     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6873 }
6874
6875
6876 #-> sub CPAN::Distribution::make ;
6877 sub make {
6878     my($self) = @_;
6879     if (my $goto = $self->prefs->{goto}) {
6880         return $self->goto($goto);
6881     }
6882     my $make = $self->{modulebuild} ? "Build" : "make";
6883     # Emergency brake if they said install Pippi and get newest perl
6884     if ($self->isa_perl) {
6885       if (
6886           $self->called_for ne $self->id &&
6887           ! $self->{force_update}
6888          ) {
6889         # if we die here, we break bundles
6890         $CPAN::Frontend
6891             ->mywarn(sprintf(
6892                              qq{The most recent version "%s" of the module "%s"
6893 is part of the perl-%s distribution. To install that, you need to run
6894   force install %s   --or--
6895   install %s
6896 },
6897                              $CPAN::META->instance(
6898                                                    'CPAN::Module',
6899                                                    $self->called_for
6900                                                   )->cpan_version,
6901                              $self->called_for,
6902                              $self->isa_perl,
6903                              $self->called_for,
6904                              $self->id,
6905                             ));
6906         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6907         $CPAN::Frontend->mysleep(1);
6908         return;
6909       }
6910     }
6911     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6912     $self->get;
6913     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6914                            ? $ENV{PERL5LIB}
6915                            : ($ENV{PERLLIB} || "");
6916     $CPAN::META->set_perl5lib;
6917     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6918
6919     if ($CPAN::Signal){
6920       delete $self->{force_update};
6921       return;
6922     }
6923
6924     my $builddir;
6925   EXCUSE: {
6926         my @e;
6927         if (!$self->{archived} || $self->{archived} eq "NO") {
6928             push @e, "Is neither a tar nor a zip archive.";
6929         }
6930
6931         if (!$self->{unwrapped}
6932             || (
6933                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6934                 $self->{unwrapped}->failed :
6935                 $self->{unwrapped} =~ /^NO/
6936                )) {
6937             push @e, "Had problems unarchiving. Please build manually";
6938         }
6939
6940         unless ($self->{force_update}) {
6941             exists $self->{signature_verify} and
6942                 (
6943                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6944                  $self->{signature_verify}->failed :
6945                  $self->{signature_verify} =~ /^NO/
6946                 )
6947                 and push @e, "Did not pass the signature test.";
6948         }
6949
6950         if (exists $self->{writemakefile} &&
6951             (
6952              UNIVERSAL::can($self->{writemakefile},"failed") ?
6953              $self->{writemakefile}->failed :
6954              $self->{writemakefile} =~ /^NO/
6955             )) {
6956             # XXX maybe a retry would be in order?
6957             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6958                 $self->{writemakefile}->text :
6959                     $self->{writemakefile};
6960             $err =~ s/^NO\s*//;
6961             $err ||= "Had some problem writing Makefile";
6962             $err .= ", won't make";
6963             push @e, $err;
6964         }
6965
6966         if (defined $self->{make}) {
6967             if ($self->{make}->failed) {
6968                 if ($self->{force_update}) {
6969                     # Trying an already failed 'make' (unless somebody else blocks)
6970                 } else {
6971                     # introduced for turning recursion detection into a distrostatus
6972                     my $error = length $self->{make}>3
6973                         ? substr($self->{make},3) : "Unknown error";
6974                     $CPAN::Frontend->mywarn("Could not make: $error\n");
6975                     $self->store_persistent_state;
6976                     return;
6977                 }
6978             } else {
6979                 push @e, "Has already been made";
6980             }
6981         }
6982
6983         if ($self->{later}) { # see also undelay
6984             if ($self->unsat_prereq) {
6985                 push @e, $self->{later};
6986             }
6987         }
6988
6989         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6990         $builddir = $self->dir or
6991             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6992         unless (chdir $builddir) {
6993             push @e, "Couldn't chdir to '$builddir': $!";
6994         }
6995         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6996     }
6997     if ($CPAN::Signal){
6998       delete $self->{force_update};
6999       return;
7000     }
7001     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7002     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7003
7004     if ($^O eq 'MacOS') {
7005         Mac::BuildTools::make($self);
7006         return;
7007     }
7008
7009     my %env;
7010     while (my($k,$v) = each %ENV) {
7011         next unless defined $v;
7012         $env{$k} = $v;
7013     }
7014     local %ENV = %env;
7015     my $system;
7016     if (my $commandline = $self->prefs->{pl}{commandline}) {
7017         $system = $commandline;
7018         $ENV{PERL} = $^X;
7019     } elsif ($self->{'configure'}) {
7020         $system = $self->{'configure'};
7021     } elsif ($self->{modulebuild}) {
7022         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7023         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7024     } else {
7025         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7026         my $switch = "";
7027 # This needs a handler that can be turned on or off:
7028 #       $switch = "-MExtUtils::MakeMaker ".
7029 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7030 #           if $] > 5.00310;
7031         my $makepl_arg = $self->make_x_arg("pl");
7032         $system = sprintf("%s%s Makefile.PL%s",
7033                           $perl,
7034                           $switch ? " $switch" : "",
7035                           $makepl_arg ? " $makepl_arg" : "",
7036                          );
7037     }
7038     if (my $env = $self->prefs->{pl}{env}) {
7039         for my $e (keys %$env) {
7040             $ENV{$e} = $env->{$e};
7041         }
7042     }
7043     if (exists $self->{writemakefile}) {
7044     } else {
7045         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7046         my($ret,$pid);
7047         $@ = "";
7048         my $go_via_alarm;
7049         if ($CPAN::Config->{inactivity_timeout}) {
7050             require Config;
7051             if ($Config::Config{d_alarm}
7052                 &&
7053                 $Config::Config{d_alarm} eq "define"
7054                ) {
7055                 $go_via_alarm++
7056             } else {
7057                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7058                                         "variable 'inactivity_timeout' to ".
7059                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7060                                         "on this machine the system call 'alarm' ".
7061                                         "isn't available. This means that we cannot ".
7062                                         "provide the feature of intercepting long ".
7063                                         "waiting code and will turn this feature off.\n"
7064                                        );
7065                 $CPAN::Config->{inactivity_timeout} = 0;
7066             }
7067         }
7068         if ($go_via_alarm) {
7069             eval {
7070                 alarm $CPAN::Config->{inactivity_timeout};
7071                 local $SIG{CHLD}; # = sub { wait };
7072                 if (defined($pid = fork)) {
7073                     if ($pid) { #parent
7074                         # wait;
7075                         waitpid $pid, 0;
7076                     } else {    #child
7077                         # note, this exec isn't necessary if
7078                         # inactivity_timeout is 0. On the Mac I'd
7079                         # suggest, we set it always to 0.
7080                         exec $system;
7081                     }
7082                 } else {
7083                     $CPAN::Frontend->myprint("Cannot fork: $!");
7084                     return;
7085                 }
7086             };
7087             alarm 0;
7088             if ($@){
7089                 kill 9, $pid;
7090                 waitpid $pid, 0;
7091                 my $err = "$@";
7092                 $CPAN::Frontend->myprint($err);
7093                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7094                 $@ = "";
7095                 return;
7096             }
7097         } else {
7098             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7099                 $ret = $self->_run_via_expect($system,$expect_model);
7100                 if (! defined $ret
7101                     && $self->{writemakefile}
7102                     && $self->{writemakefile}->failed) {
7103                     # timeout
7104                     return;
7105                 }
7106             } else {
7107                 $ret = system($system);
7108             }
7109             if ($ret != 0) {
7110                 $self->{writemakefile} = CPAN::Distrostatus
7111                     ->new("NO '$system' returned status $ret");
7112                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7113                 $self->store_persistent_state;
7114                 return;
7115             }
7116         }
7117         if (-f "Makefile" || -f "Build") {
7118           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7119           delete $self->{make_clean}; # if cleaned before, enable next
7120         } else {
7121           $self->{writemakefile} = CPAN::Distrostatus
7122               ->new(qq{NO -- Unknown reason});
7123         }
7124     }
7125     if ($CPAN::Signal){
7126       delete $self->{force_update};
7127       return;
7128     }
7129     if (my @prereq = $self->unsat_prereq){
7130         if ($prereq[0][0] eq "perl") {
7131             my $need = "requires perl '$prereq[0][1]'";
7132             my $id = $self->pretty_id;
7133             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7134             $self->{make} = CPAN::Distrostatus->new("NO $need");
7135             $self->store_persistent_state;
7136             return;
7137         } else {
7138             my $follow = eval { $self->follow_prereqs(@prereq); };
7139             if (0) {
7140             } elsif ($follow){
7141                 # signal success to the queuerunner
7142                 return 1;
7143             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7144                 $CPAN::Frontend->mywarn($@);
7145                 return;
7146             }
7147         }
7148     }
7149     if ($CPAN::Signal){
7150       delete $self->{force_update};
7151       return;
7152     }
7153     if (my $commandline = $self->prefs->{make}{commandline}) {
7154         $system = $commandline;
7155         $ENV{PERL} = $^X;
7156     } else {
7157         if ($self->{modulebuild}) {
7158             unless (-f "Build") {
7159                 my $cwd = CPAN::anycwd();
7160                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7161                                         " in cwd[$cwd]. Danger, Will Robinson!");
7162                 $CPAN::Frontend->mysleep(5);
7163             }
7164             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7165         } else {
7166             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7167         }
7168         $system =~ s/\s+$//;
7169         my $make_arg = $self->make_x_arg("make");
7170         $system = sprintf("%s%s",
7171                           $system,
7172                           $make_arg ? " $make_arg" : "",
7173                          );
7174     }
7175     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7176                                                # ENV of PL, not the
7177                                                # outer ENV, but
7178                                                # unlikely to be a risk
7179         for my $e (keys %$env) {
7180             $ENV{$e} = $env->{$e};
7181         }
7182     }
7183     my $expect_model = $self->_prefs_with_expect("make");
7184     my $want_expect = 0;
7185     if ( $expect_model && @{$expect_model->{talk}} ) {
7186         my $can_expect = $CPAN::META->has_inst("Expect");
7187         if ($can_expect) {
7188             $want_expect = 1;
7189         } else {
7190             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7191                                     "system()\n");
7192         }
7193     }
7194     my $system_ok;
7195     if ($want_expect) {
7196         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7197     } else {
7198         $system_ok = system($system) == 0;
7199     }
7200     $self->introduce_myself;
7201     if ( $system_ok ) {
7202          $CPAN::Frontend->myprint("  $system -- OK\n");
7203          $self->{make} = CPAN::Distrostatus->new("YES");
7204     } else {
7205          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7206          $self->{make} = CPAN::Distrostatus->new("NO");
7207          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7208     }
7209     $self->store_persistent_state;
7210 }
7211
7212 # CPAN::Distribution::_run_via_expect
7213 sub _run_via_expect {
7214     my($self,$system,$expect_model) = @_;
7215     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7216     if ($CPAN::META->has_inst("Expect")) {
7217         my $expo = Expect->new;  # expo Expect object;
7218         $expo->spawn($system);
7219         $expect_model->{mode} ||= "deterministic";
7220         if ($expect_model->{mode} eq "deterministic") {
7221             return $self->_run_via_expect_deterministic($expo,$expect_model);
7222         } elsif ($expect_model->{mode} eq "anyorder") {
7223             return $self->_run_via_expect_anyorder($expo,$expect_model);
7224         } else {
7225             die "Panic: Illegal expect mode: $expect_model->{mode}";
7226         }
7227     } else {
7228         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7229         return system($system);
7230     }
7231 }
7232
7233 sub _run_via_expect_anyorder {
7234     my($self,$expo,$expect_model) = @_;
7235     my $timeout = $expect_model->{timeout} || 5;
7236     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7237     my $but = "";
7238   EXPECT: while () {
7239         my($eof,$ran_into_timeout);
7240         my @match = $expo->expect($timeout,
7241                                   [ eof => sub {
7242                                         $eof++;
7243                                     } ],
7244                                   [ timeout => sub {
7245                                         $ran_into_timeout++;
7246                                     } ],
7247                                   -re => eval"qr{.}",
7248                                  );
7249         if ($match[2]) {
7250             $but .= $match[2];
7251         }
7252         $but .= $expo->clear_accum;
7253         if ($eof) {
7254             $expo->soft_close;
7255             return $expo->exitstatus();
7256         } elsif ($ran_into_timeout) {
7257             # warn "DEBUG: they are asking a question, but[$but]";
7258             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7259                 my($next,$send) = @expectacopy[$i,$i+1];
7260                 my $regex = eval "qr{$next}";
7261                 # warn "DEBUG: will compare with regex[$regex].";
7262                 if ($but =~ /$regex/) {
7263                     # warn "DEBUG: will send send[$send]";
7264                     $expo->send($send);
7265                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7266                     next EXPECT;
7267                 }
7268             }
7269             my $why = "could not answer a question during the dialog";
7270             $CPAN::Frontend->mywarn("Failing: $why\n");
7271             $self->{writemakefile} =
7272                 CPAN::Distrostatus->new("NO $why");
7273             return;
7274         }
7275     }
7276 }
7277
7278 sub _run_via_expect_deterministic {
7279     my($self,$expo,$expect_model) = @_;
7280     my $ran_into_timeout;
7281     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7282     my $expecta = $expect_model->{talk};
7283   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7284         my($re,$send) = @$expecta[$i,$i+1];
7285         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7286         my $regex = eval "qr{$re}";
7287         $expo->expect($timeout,
7288                       [ eof => sub {
7289                             my $but = $expo->clear_accum;
7290                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7291 expected[$regex]\nbut[$but]\n\n");
7292                             last EXPECT;
7293                         } ],
7294                       [ timeout => sub {
7295                             my $but = $expo->clear_accum;
7296                             $CPAN::Frontend->mywarn("TIMEOUT
7297 expected[$regex]\nbut[$but]\n\n");
7298                             $ran_into_timeout++;
7299                         } ],
7300                       -re => $regex);
7301         if ($ran_into_timeout){
7302             # note that the caller expects 0 for success
7303             $self->{writemakefile} =
7304                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7305             return;
7306         }
7307         $expo->send($send);
7308     }
7309     $expo->soft_close;
7310     return $expo->exitstatus();
7311 }
7312
7313 #-> CPAN::Distribution::_validate_distropref
7314 sub _validate_distropref {
7315     my($self,@args) = @_;
7316     if (
7317         $CPAN::META->has_inst("CPAN::Kwalify")
7318         &&
7319         $CPAN::META->has_inst("Kwalify")
7320        ) {
7321         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7322         if ($@) {
7323             $CPAN::Frontend->mywarn($@);
7324         }
7325     } else {
7326         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7327     }
7328 }
7329
7330 #-> CPAN::Distribution::_find_prefs
7331 sub _find_prefs {
7332     my($self) = @_;
7333     my $distroid = $self->pretty_id;
7334     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7335     my $prefs_dir = $CPAN::Config->{prefs_dir};
7336     eval { File::Path::mkpath($prefs_dir); };
7337     if ($@) {
7338         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7339     }
7340     my $yaml_module = CPAN::_yaml_module;
7341     my @extensions;
7342     if ($CPAN::META->has_inst($yaml_module)) {
7343         push @extensions, "yml";
7344     } else {
7345         my @fallbacks;
7346         if ($CPAN::META->has_inst("Data::Dumper")) {
7347             push @extensions, "dd";
7348             push @fallbacks, "Data::Dumper";
7349         }
7350         if ($CPAN::META->has_inst("Storable")) {
7351             push @extensions, "st";
7352             push @fallbacks, "Storable";
7353         }
7354         if (@fallbacks) {
7355             local $" = " and ";
7356             unless ($self->{have_complained_about_missing_yaml}++) {
7357                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7358                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7359             }
7360         } else {
7361             unless ($self->{have_complained_about_missing_yaml}++) {
7362                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7363                                         "read prefs '$prefs_dir'\n");
7364             }
7365         }
7366     }
7367     if (@extensions) {
7368         my $dh = DirHandle->new($prefs_dir)
7369             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7370       DIRENT: for (sort $dh->read) {
7371             next if $_ eq "." || $_ eq "..";
7372             my $exte = join "|", @extensions;
7373             next unless /\.($exte)$/;
7374             my $thisexte = $1;
7375             my $abs = File::Spec->catfile($prefs_dir, $_);
7376             if (-f $abs) {
7377                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7378                 my @distropref;
7379                 if ($thisexte eq "yml") {
7380                     # need no eval because if we have no YAML we do not try to read *.yml
7381                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7382                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7383                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7384                 } elsif ($thisexte eq "dd") {
7385                     package CPAN::Eval;
7386                     no strict;
7387                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7388                     local $/;
7389                     my $eval = <FH>;
7390                     close FH;
7391                     eval $eval;
7392                     if ($@) {
7393                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7394                     }
7395                     my $i = 1;
7396                     while (${"VAR".$i}) {
7397                         push @distropref, ${"VAR".$i};
7398                         $i++;
7399                     }
7400                 } elsif ($thisexte eq "st") {
7401                     # eval because Storable is never forward compatible
7402                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7403                     if ($@) {
7404                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7405                                                 "$_, skipping\: $@");
7406                         $CPAN::Frontend->mysleep(4);
7407                         next DIRENT;
7408                     }
7409                 }
7410                 # $DB::single=1;
7411                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7412               ELEMENT: for my $y (0..$#distropref) {
7413                     my $distropref = $distropref[$y];
7414                     $self->_validate_distropref($distropref,$abs,$y);
7415                     my $match = $distropref->{match};
7416                     unless ($match) {
7417                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7418                         next ELEMENT;
7419                     }
7420                     my $ok = 1;
7421                     # do not take the order of C<keys %$match> because
7422                     # "module" is by far the slowest
7423                     my $saw_valid_subkeys = 0;
7424                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7425                         next unless exists $match->{$sub_attribute};
7426                         $saw_valid_subkeys++;
7427                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7428                         if ($sub_attribute eq "module") {
7429                             my $okm = 0;
7430                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7431                             my @modules = $self->containsmods;
7432                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7433                           MODULE: for my $module (@modules) {
7434                                 $okm ||= $module =~ /$qr/;
7435                                 last MODULE if $okm;
7436                             }
7437                             $ok &&= $okm;
7438                         } elsif ($sub_attribute eq "distribution") {
7439                             my $okd = $distroid =~ /$qr/;
7440                             $ok &&= $okd;
7441                         } elsif ($sub_attribute eq "perl") {
7442                             my $okp = $^X =~ /$qr/;
7443                             $ok &&= $okp;
7444                         } elsif ($sub_attribute eq "perlconfig") {
7445                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7446                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7447                                 # XXX should probably warn if Config does not exist
7448                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7449                                 $ok &&= $okpc;
7450                                 last if $ok == 0;
7451                             }
7452                         } else {
7453                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7454                                                    "unknown sub_attribut '$sub_attribute'. ".
7455                                                    "Please ".
7456                                                    "remove, cannot continue.");
7457                         }
7458                         last if $ok == 0; # short circuit
7459                     }
7460                     unless ($saw_valid_subkeys) {
7461                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7462                                                "missing match/* subattribute. ".
7463                                                "Please ".
7464                                                "remove, cannot continue.");
7465                     }
7466                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7467                     if ($ok) {
7468                         return {
7469                                 prefs => $distropref,
7470                                 prefs_file => $abs,
7471                                 prefs_file_doc => $y,
7472                                };
7473                     }
7474
7475                 }
7476             }
7477         }
7478         $dh->close;
7479     }
7480     return;
7481 }
7482
7483 # CPAN::Distribution::prefs
7484 sub prefs {
7485     my($self) = @_;
7486     if (exists $self->{negative_prefs_cache}
7487         &&
7488         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7489        ) {
7490         delete $self->{negative_prefs_cache};
7491         delete $self->{prefs};
7492     }
7493     if (exists $self->{prefs}) {
7494         return $self->{prefs}; # XXX comment out during debugging
7495     }
7496     if ($CPAN::Config->{prefs_dir}) {
7497         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7498         my $prefs = $self->_find_prefs();
7499         $prefs ||= ""; # avoid warning next line
7500         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7501         if ($prefs) {
7502             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7503                 $self->{$x} = $prefs->{$x};
7504             }
7505             my $bs = sprintf(
7506                              "%s[%s]",
7507                              File::Basename::basename($self->{prefs_file}),
7508                              $self->{prefs_file_doc},
7509                             );
7510             my $filler1 = "_" x 22;
7511             my $filler2 = int(66 - length($bs))/2;
7512             $filler2 = 0 if $filler2 < 0;
7513             $filler2 = " " x $filler2;
7514             $CPAN::Frontend->myprint("
7515 $filler1 D i s t r o P r e f s $filler1
7516 $filler2 $bs $filler2
7517 ");
7518             $CPAN::Frontend->mysleep(1);
7519             return $self->{prefs};
7520         }
7521     }
7522     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7523     return $self->{prefs} = +{};
7524 }
7525
7526 # CPAN::Distribution::make_x_arg
7527 sub make_x_arg {
7528     my($self, $whixh) = @_;
7529     my $make_x_arg;
7530     my $prefs = $self->prefs;
7531     if (
7532         $prefs
7533         && exists $prefs->{$whixh}
7534         && exists $prefs->{$whixh}{args}
7535         && $prefs->{$whixh}{args}
7536        ) {
7537         $make_x_arg = join(" ",
7538                            map {CPAN::HandleConfig
7539                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7540                           );
7541     }
7542     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7543     $make_x_arg ||= $CPAN::Config->{$what};
7544     return $make_x_arg;
7545 }
7546
7547 # CPAN::Distribution::_make_command
7548 sub _make_command {
7549     my ($self) = @_;
7550     if ($self) {
7551         return
7552             CPAN::HandleConfig
7553                 ->safe_quote(
7554                              CPAN::HandleConfig->prefs_lookup($self,
7555                                                               q{make})
7556                              || $Config::Config{make}
7557                              || 'make'
7558                             );
7559     } else {
7560         # Old style call, without object. Deprecated
7561         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7562         return
7563           safe_quote(undef,
7564                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7565                      || $CPAN::Config->{make}
7566                      || $Config::Config{make}
7567                      || 'make');
7568     }
7569 }
7570
7571 #-> sub CPAN::Distribution::follow_prereqs ;
7572 sub follow_prereqs {
7573     my($self) = shift;
7574     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7575     return unless @prereq_tuples;
7576     my @prereq = map { $_->[0] } @prereq_tuples;
7577     my $pretty_id = $self->pretty_id;
7578     my %map = (
7579                b => "build_requires",
7580                r => "requires",
7581                c => "commandline",
7582               );
7583     my($filler1,$filler2,$filler3,$filler4);
7584     # $DB::single=1;
7585     my $unsat = "Unsatisfied dependencies detected during";
7586     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7587     {
7588         my $r = int(($w - length($unsat))/2);
7589         my $l = $w - length($unsat) - $r;
7590         $filler1 = "-"x4 . " "x$l;
7591         $filler2 = " "x$r . "-"x4 . "\n";
7592     }
7593     {
7594         my $r = int(($w - length($pretty_id))/2);
7595         my $l = $w - length($pretty_id) - $r;
7596         $filler3 = "-"x4 . " "x$l;
7597         $filler4 = " "x$r . "-"x4 . "\n";
7598     }
7599     $CPAN::Frontend->
7600         myprint("$filler1 $unsat $filler2".
7601                 "$filler3 $pretty_id $filler4".
7602                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7603                );
7604     my $follow = 0;
7605     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7606         $follow = 1;
7607     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7608         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7609 "Shall I follow them and prepend them to the queue
7610 of modules we are processing right now?", "yes");
7611         $follow = $answer =~ /^\s*y/i;
7612     } else {
7613         local($") = ", ";
7614         $CPAN::Frontend->
7615             myprint("  Ignoring dependencies on modules @prereq\n");
7616     }
7617     if ($follow) {
7618         my $id = $self->id;
7619         # color them as dirty
7620         for my $p (@prereq) {
7621             # warn "calling color_cmd_tmps(0,1)";
7622             my $any = CPAN::Shell->expandany($p);
7623             if ($any) {
7624                 $any->color_cmd_tmps(0,2);
7625             } else {
7626                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7627                 $CPAN::Frontend->mysleep(2);
7628             }
7629         }
7630         # queue them and re-queue yourself
7631         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7632                                reverse @prereq_tuples);
7633         $self->{later} = "Delayed until after prerequisites";
7634         return 1; # signal success to the queuerunner
7635     }
7636 }
7637
7638 #-> sub CPAN::Distribution::unsat_prereq ;
7639 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7640 # return ([perl=>5.008]) if we need a newer perl than we are running under
7641 sub unsat_prereq {
7642     my($self) = @_;
7643     my $prereq_pm = $self->prereq_pm or return;
7644     my(@need);
7645     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7646     my @merged = %merged;
7647     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7648   NEED: while (my($need_module, $need_version) = each %merged) {
7649         my($available_version,$available_file,$nmo);
7650         if ($need_module eq "perl") {
7651             $available_version = $];
7652             $available_file = $^X;
7653         } else {
7654             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7655             next if $nmo->uptodate;
7656             $available_file = $nmo->available_file;
7657
7658             # if they have not specified a version, we accept any installed one
7659             if (defined $available_file
7660                 and ( # a few quick shortcurcuits
7661                      not defined $need_version
7662                      or $need_version eq '0'    # "==" would trigger warning when not numeric
7663                      or $need_version eq "undef"
7664                     )) {
7665                 next NEED;
7666             }
7667
7668             $available_version = $nmo->available_version;
7669         }
7670
7671         # We only want to install prereqs if either they're not installed
7672         # or if the installed version is too old. We cannot omit this
7673         # check, because if 'force' is in effect, nobody else will check.
7674         if (defined $available_file) {
7675             my(@all_requirements) = split /\s*,\s*/, $need_version;
7676             local($^W) = 0;
7677             my $ok = 0;
7678           RQ: for my $rq (@all_requirements) {
7679                 if ($rq =~ s|>=\s*||) {
7680                 } elsif ($rq =~ s|>\s*||) {
7681                     # 2005-12: one user
7682                     if (CPAN::Version->vgt($available_version,$rq)){
7683                         $ok++;
7684                     }
7685                     next RQ;
7686                 } elsif ($rq =~ s|!=\s*||) {
7687                     # 2005-12: no user
7688                     if (CPAN::Version->vcmp($available_version,$rq)){
7689                         $ok++;
7690                         next RQ;
7691                     } else {
7692                         last RQ;
7693                     }
7694                 } elsif ($rq =~ m|<=?\s*|) {
7695                     # 2005-12: no user
7696                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7697                     $ok++;
7698                     next RQ;
7699                 }
7700                 if (! CPAN::Version->vgt($rq, $available_version)){
7701                     $ok++;
7702                 }
7703                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7704                                     "available_version[%s]rq[%s]ok[%d]",
7705                                     $need_module,
7706                                     $available_file,
7707                                     $available_version,
7708                                     CPAN::Version->readable($rq),
7709                                     $ok,
7710                                    )) if $CPAN::DEBUG;
7711             }
7712             next NEED if $ok == @all_requirements;
7713         }
7714
7715         if ($need_module eq "perl") {
7716             return ["perl", $need_version];
7717         }
7718         if ($self->{sponsored_mods}{$need_module}++){
7719             # We have already sponsored it and for some reason it's still
7720             # not available. So we do ... what??
7721
7722             # if we push it again, we have a potential infinite loop
7723
7724             # The following "next" was a very problematic construct.
7725             # It helped a lot but broke some day and had to be
7726             # replaced.
7727
7728             # We must be able to deal with modules that come again and
7729             # again as a prereq and have themselves prereqs and the
7730             # queue becomes long but finally we would find the correct
7731             # order. The RecursiveDependency check should trigger a
7732             # die when it's becoming too weird. Unfortunately removing
7733             # this next breaks many other things.
7734
7735             # The bug that brought this up is described in Todo under
7736             # "5.8.9 cannot install Compress::Zlib"
7737
7738             # next; # this is the next that had to go away
7739
7740             # The following "next NEED" are fine and the error message
7741             # explains well what is going on. For example when the DBI
7742             # fails and consequently DBD::SQLite fails and now we are
7743             # processing CPAN::SQLite. Then we must have a "next" for
7744             # DBD::SQLite. How can we get it and how can we identify
7745             # all other cases we must identify?
7746
7747             my $do = $nmo->distribution;
7748             next NEED unless $do; # not on CPAN
7749           NOSAYER: for my $nosayer (
7750                                     "unwrapped",
7751                                     "writemakefile",
7752                                     "signature_verify",
7753                                     "make",
7754                                     "make_test",
7755                                     "install",
7756                                     "make_clean",
7757                                    ) {
7758                 if ($do->{$nosayer}) {
7759                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
7760                         $do->{$nosayer}->failed :
7761                         $do->{$nosayer} =~ /^NO/) {
7762                         if ($nosayer eq "make_test"
7763                             &&
7764                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7765                            ) {
7766                             next NOSAYER;
7767                         }
7768                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7769                                                 "'$need_module => $need_version' ".
7770                                                 "for '$self->{ID}' failed when ".
7771                                                 "processing '$do->{ID}' with ".
7772                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
7773                                                 "but chances to succeed are limited.\n"
7774                                                );
7775                         next NEED;
7776                     } else { # the other guy succeeded
7777                         if ($nosayer eq "install") {
7778                             # we had this with
7779                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
7780                             # 2007-03
7781                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7782                                                     "'$need_module => $need_version' ".
7783                                                     "for '$self->{ID}' already installed ".
7784                                                     "but installation looks suspicious. ".
7785                                                     "Skipping another installation attempt, ".
7786                                                     "to prevent looping endlessly.\n"
7787                                                    );
7788                             next NEED;
7789                         }
7790                     }
7791                 }
7792             }
7793         }
7794         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7795         push @need, [$need_module,$needed_as];
7796     }
7797     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7798     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7799     @need;
7800 }
7801
7802 #-> sub CPAN::Distribution::read_yaml ;
7803 sub read_yaml {
7804     my($self) = @_;
7805     return $self->{yaml_content} if exists $self->{yaml_content};
7806     my $build_dir = $self->{build_dir};
7807     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7808     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7809     return unless -f $yaml;
7810     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7811     if ($@) {
7812         $CPAN::Frontend->mywarn("Could not read ".
7813                                 "'$yaml'. Falling back to other ".
7814                                 "methods to determine prerequisites\n");
7815         return $self->{yaml_content} = undef; # if we die, then we
7816                                               # cannot read YAML's own
7817                                               # META.yml
7818     }
7819     # not "authoritative"
7820     if (not exists $self->{yaml_content}{dynamic_config}
7821         or $self->{yaml_content}{dynamic_config}
7822        ) {
7823         $self->{yaml_content} = undef;
7824     }
7825     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7826         if $CPAN::DEBUG;
7827     return $self->{yaml_content};
7828 }
7829
7830 #-> sub CPAN::Distribution::prereq_pm ;
7831 sub prereq_pm {
7832     my($self) = @_;
7833     $self->{prereq_pm_detected} ||= 0;
7834     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7835     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7836     return unless $self->{writemakefile}  # no need to have succeeded
7837                                           # but we must have run it
7838         || $self->{modulebuild};
7839     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7840                 $self->{writemakefile}||"",
7841                 $self->{modulebuild}||"",
7842                ) if $CPAN::DEBUG;
7843     my($req,$breq);
7844     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7845         $req =  $yaml->{requires} || {};
7846         $breq =  $yaml->{build_requires} || {};
7847         undef $req unless ref $req eq "HASH" && %$req;
7848         if ($req) {
7849             if ($yaml->{generated_by} &&
7850                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7851                 my $eummv = do { local $^W = 0; $1+0; };
7852                 if ($eummv < 6.2501) {
7853                     # thanks to Slaven for digging that out: MM before
7854                     # that could be wrong because it could reflect a
7855                     # previous release
7856                     undef $req;
7857                 }
7858             }
7859             my $areq;
7860             my $do_replace;
7861             while (my($k,$v) = each %{$req||{}}) {
7862                 if ($v =~ /\d/) {
7863                     $areq->{$k} = $v;
7864                 } elsif ($k =~ /[A-Za-z]/ &&
7865                          $v =~ /[A-Za-z]/ &&
7866                          $CPAN::META->exists("Module",$v)
7867                         ) {
7868                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7869                                             "requires hash: $k => $v; I'll take both ".
7870                                             "key and value as a module name\n");
7871                     $CPAN::Frontend->mysleep(1);
7872                     $areq->{$k} = 0;
7873                     $areq->{$v} = 0;
7874                     $do_replace++;
7875                 }
7876             }
7877             $req = $areq if $do_replace;
7878         }
7879     }
7880     unless ($req || $breq) {
7881         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7882         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7883         my $fh;
7884         if (-f $makefile
7885             and
7886             $fh = FileHandle->new("<$makefile\0")) {
7887             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7888             local($/) = "\n";
7889             while (<$fh>) {
7890                 last if /MakeMaker post_initialize section/;
7891                 my($p) = m{^[\#]
7892                            \s+PREREQ_PM\s+=>\s+(.+)
7893                        }x;
7894                 next unless $p;
7895                 # warn "Found prereq expr[$p]";
7896
7897                 #  Regexp modified by A.Speer to remember actual version of file
7898                 #  PREREQ_PM hash key wants, then add to
7899                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7900                     # In case a prereq is mentioned twice, complain.
7901                     if ( defined $req->{$1} ) {
7902                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7903                             "last mention wins";
7904                     }
7905                     my($m,$n) = ($1,$2);
7906                     if ($n =~ /^q\[(.*?)\]$/) {
7907                         $n = $1;
7908                     }
7909                     $req->{$m} = $n;
7910                 }
7911                 last;
7912             }
7913         }
7914     }
7915     unless ($req || $breq) {
7916         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7917         my $buildfile = File::Spec->catfile($build_dir,"Build");
7918         if (-f $buildfile) {
7919             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7920             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7921             if (-f $build_prereqs) {
7922                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7923                 my $content = do { local *FH;
7924                                    open FH, $build_prereqs
7925                                        or $CPAN::Frontend->mydie("Could not open ".
7926                                                                  "'$build_prereqs': $!");
7927                                    local $/;
7928                                    <FH>;
7929                                };
7930                 my $bphash = eval $content;
7931                 if ($@) {
7932                 } else {
7933                     $req  = $bphash->{requires} || +{};
7934                     $breq = $bphash->{build_requires} || +{};
7935                 }
7936             }
7937         }
7938     }
7939     if (-f "Build.PL"
7940         && ! -f "Makefile.PL"
7941         && ! exists $req->{"Module::Build"}
7942         && ! $CPAN::META->has_inst("Module::Build")) {
7943         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7944                                 "undeclared prerequisite.\n".
7945                                 "  Adding it now as such.\n"
7946                                );
7947         $CPAN::Frontend->mysleep(5);
7948         $req->{"Module::Build"} = 0;
7949         delete $self->{writemakefile};
7950     }
7951     if ($req || $breq) {
7952         $self->{prereq_pm_detected}++;
7953         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7954     }
7955 }
7956
7957 #-> sub CPAN::Distribution::test ;
7958 sub test {
7959     my($self) = @_;
7960     if (my $goto = $self->prefs->{goto}) {
7961         return $self->goto($goto);
7962     }
7963     $self->make;
7964     if ($CPAN::Signal){
7965       delete $self->{force_update};
7966       return;
7967     }
7968     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7969     if ($self->{notest}) {
7970         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7971         return 1;
7972     }
7973
7974     my $make = $self->{modulebuild} ? "Build" : "make";
7975
7976     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7977                            ? $ENV{PERL5LIB}
7978                            : ($ENV{PERLLIB} || "");
7979
7980     $CPAN::META->set_perl5lib;
7981     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7982
7983     $CPAN::Frontend->myprint("Running $make test\n");
7984
7985 #    if (my @prereq = $self->unsat_prereq){
7986 #        if ( $CPAN::DEBUG ) {
7987 #            require Data::Dumper;
7988 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7989 #        }
7990 #        unless ($prereq[0][0] eq "perl") {
7991 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7992 #        }
7993 #    }
7994
7995   EXCUSE: {
7996         my @e;
7997         if ($self->{make} or $self->{later}) {
7998             # go ahead
7999         } else {
8000             push @e,
8001                 "Make had some problems, won't test";
8002         }
8003
8004         exists $self->{make} and
8005             (
8006              UNIVERSAL::can($self->{make},"failed") ?
8007              $self->{make}->failed :
8008              $self->{make} =~ /^NO/
8009             ) and push @e, "Can't test without successful make";
8010         $self->{badtestcnt} ||= 0;
8011         if ($self->{badtestcnt} > 0) {
8012             require Data::Dumper;
8013             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8014             push @e, "Won't repeat unsuccessful test during this command";
8015         }
8016
8017         push @e, $self->{later} if $self->{later};
8018
8019         if (exists $self->{build_dir}) {
8020             if (exists $self->{make_test}) {
8021                 if (
8022                     UNIVERSAL::can($self->{make_test},"failed") ?
8023                     $self->{make_test}->failed :
8024                     $self->{make_test} =~ /^NO/
8025                    ) {
8026                     if (
8027                         UNIVERSAL::can($self->{make_test},"commandid")
8028                         &&
8029                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8030                        ) {
8031                         push @e, "Has already been tested within this command";
8032                     }
8033                 } else {
8034                     push @e, "Has already been tested successfully";
8035                 }
8036             }
8037         } elsif (!@e) {
8038             push @e, "Has no own directory";
8039         }
8040         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8041         unless (chdir $self->{build_dir}) {
8042             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8043         }
8044         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8045     }
8046     $self->debug("Changed directory to $self->{build_dir}")
8047         if $CPAN::DEBUG;
8048
8049     if ($^O eq 'MacOS') {
8050         Mac::BuildTools::make_test($self);
8051         return;
8052     }
8053
8054     if ($self->{modulebuild}) {
8055         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8056         if (CPAN::Version->vlt($v,2.62)) {
8057             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8058   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8059             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8060             return;
8061         }
8062     }
8063
8064     my $system;
8065     if (my $commandline = $self->prefs->{test}{commandline}) {
8066         $system = $commandline;
8067         $ENV{PERL} = $^X;
8068     } elsif ($self->{modulebuild}) {
8069         $system = sprintf "%s test", $self->_build_command();
8070     } else {
8071         $system = join " ", $self->_make_command(), "test";
8072     }
8073     my $make_test_arg = $self->make_x_arg("test");
8074     $system = sprintf("%s%s",
8075                       $system,
8076                       $make_test_arg ? " $make_test_arg" : "",
8077                      );
8078     my($tests_ok);
8079     my %env;
8080     while (my($k,$v) = each %ENV) {
8081         next unless defined $v;
8082         $env{$k} = $v;
8083     }
8084     local %ENV = %env;
8085     if (my $env = $self->prefs->{test}{env}) {
8086         for my $e (keys %$env) {
8087             $ENV{$e} = $env->{$e};
8088         }
8089     }
8090     my $expect_model = $self->_prefs_with_expect("test");
8091     my $want_expect = 0;
8092     if ( $expect_model && @{$expect_model->{talk}} ) {
8093         my $can_expect = $CPAN::META->has_inst("Expect");
8094         if ($can_expect) {
8095             $want_expect = 1;
8096         } else {
8097             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8098                                     "testing without\n");
8099         }
8100     }
8101     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8102                                                        q{test_report});
8103     my $want_report;
8104     if ($test_report) {
8105         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8106         if ($can_report) {
8107             $want_report = 1;
8108         } else {
8109             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8110                                     "testing without\n");
8111         }
8112     }
8113     my $ready_to_report = $want_report;
8114     if ($ready_to_report
8115         && $self->is_dot_dist
8116        ) {
8117         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8118                                 "for local directories\n");
8119         $ready_to_report = 0;
8120     }
8121     if ($ready_to_report
8122         &&
8123         $self->prefs->{patches}
8124         &&
8125         @{$self->prefs->{patches}}
8126         &&
8127         $self->{patched}
8128        ) {
8129         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8130                                 "when the source has been patched\n");
8131         $ready_to_report = 0;
8132     }
8133     if ($want_expect) {
8134         if ($ready_to_report) {
8135             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8136                                     "not supported when distroprefs specify ".
8137                                     "an interactive test\n");
8138         }
8139         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8140     } elsif ( $ready_to_report ) {
8141         $tests_ok = CPAN::Reporter::test($self, $system);
8142     } else {
8143         $tests_ok = system($system) == 0;
8144     }
8145     $self->introduce_myself;
8146     if ( $tests_ok ) {
8147         {
8148             my @prereq;
8149
8150             # local $CPAN::DEBUG = 16; # Distribution
8151             for my $m (keys %{$self->{sponsored_mods}}) {
8152                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8153                 # XXX we need available_version which reflects
8154                 # $ENV{PERL5LIB} so that already tested but not yet
8155                 # installed modules are counted.
8156                 my $available_version = $m_obj->available_version;
8157                 my $available_file = $m_obj->available_file;
8158                 if ($available_version &&
8159                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8160                    ) {
8161                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8162                         if $CPAN::DEBUG;
8163                 } elsif ($available_file
8164                          && (
8165                              !$self->{prereq_pm}{$m}
8166                              ||
8167                              $self->{prereq_pm}{$m} == 0
8168                             )
8169                         ) {
8170                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8171                     CPAN->debug("m[$m] have available_file[$available_file]")
8172                         if $CPAN::DEBUG;
8173                 } else {
8174                     push @prereq, $m;
8175                 }
8176             }
8177             if (@prereq){
8178                 my $cnt = @prereq;
8179                 my $which = join ",", @prereq;
8180                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8181                     "$cnt dependencies missing ($which)";
8182                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8183                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8184                 $self->store_persistent_state;
8185                 return;
8186             }
8187         }
8188
8189         $CPAN::Frontend->myprint("  $system -- OK\n");
8190         $self->{make_test} = CPAN::Distrostatus->new("YES");
8191         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8192         # probably impossible to need the next line because badtestcnt
8193         # has a lifespan of one command
8194         delete $self->{badtestcnt};
8195     } else {
8196         $self->{make_test} = CPAN::Distrostatus->new("NO");
8197         $self->{badtestcnt}++;
8198         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8199     }
8200     $self->store_persistent_state;
8201 }
8202
8203 sub _prefs_with_expect {
8204     my($self,$where) = @_;
8205     return unless my $prefs = $self->prefs;
8206     return unless my $where_prefs = $prefs->{$where};
8207     if ($where_prefs->{expect}) {
8208         return {
8209                 mode => "deterministic",
8210                 timeout => 15,
8211                 talk => $where_prefs->{expect},
8212                };
8213     } elsif ($where_prefs->{"eexpect"}) {
8214         return $where_prefs->{"eexpect"};
8215     }
8216     return;
8217 }
8218
8219 #-> sub CPAN::Distribution::clean ;
8220 sub clean {
8221     my($self) = @_;
8222     my $make = $self->{modulebuild} ? "Build" : "make";
8223     $CPAN::Frontend->myprint("Running $make clean\n");
8224     unless (exists $self->{archived}) {
8225         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8226                                 "/untarred, nothing done\n");
8227         return 1;
8228     }
8229     unless (exists $self->{build_dir}) {
8230         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8231         return 1;
8232     }
8233     if (exists $self->{writemakefile}
8234         and $self->{writemakefile}->failed
8235        ) {
8236         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8237         return 1;
8238     }
8239   EXCUSE: {
8240         my @e;
8241         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8242             push @e, "make clean already called once";
8243         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8244     }
8245     chdir $self->{build_dir} or
8246         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8247     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8248
8249     if ($^O eq 'MacOS') {
8250         Mac::BuildTools::make_clean($self);
8251         return;
8252     }
8253
8254     my $system;
8255     if ($self->{modulebuild}) {
8256         unless (-f "Build") {
8257             my $cwd = CPAN::anycwd();
8258             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8259                                     " in cwd[$cwd]. Danger, Will Robinson!");
8260             $CPAN::Frontend->mysleep(5);
8261         }
8262         $system = sprintf "%s clean", $self->_build_command();
8263     } else {
8264         $system  = join " ", $self->_make_command(), "clean";
8265     }
8266     my $system_ok = system($system) == 0;
8267     $self->introduce_myself;
8268     if ( $system_ok ) {
8269       $CPAN::Frontend->myprint("  $system -- OK\n");
8270
8271       # $self->force;
8272
8273       # Jost Krieger pointed out that this "force" was wrong because
8274       # it has the effect that the next "install" on this distribution
8275       # will untar everything again. Instead we should bring the
8276       # object's state back to where it is after untarring.
8277
8278       for my $k (qw(
8279                     force_update
8280                     install
8281                     writemakefile
8282                     make
8283                     make_test
8284                    )) {
8285           delete $self->{$k};
8286       }
8287       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8288
8289     } else {
8290       # Hmmm, what to do if make clean failed?
8291
8292       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8293       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8294
8295       # 2006-02-27: seems silly to me to force a make now
8296       # $self->force("make"); # so that this directory won't be used again
8297
8298     }
8299     $self->store_persistent_state;
8300 }
8301
8302 #-> sub CPAN::Distribution::goto ;
8303 sub goto {
8304     my($self,$goto) = @_;
8305     $goto = $self->normalize($goto);
8306
8307     # inject into the queue
8308
8309     CPAN::Queue->delete($self->id);
8310     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8311
8312     # and run where we left off
8313
8314     my($method) = (caller(1))[3];
8315     CPAN->instance("CPAN::Distribution",$goto)->$method;
8316     CPAN::Queue->delete_first($goto);
8317 }
8318
8319 #-> sub CPAN::Distribution::install ;
8320 sub install {
8321     my($self) = @_;
8322     if (my $goto = $self->prefs->{goto}) {
8323         return $self->goto($goto);
8324     }
8325     # $DB::single=1;
8326     unless ($self->{badtestcnt}) {
8327         $self->test;
8328     }
8329     if ($CPAN::Signal){
8330       delete $self->{force_update};
8331       return;
8332     }
8333     my $make = $self->{modulebuild} ? "Build" : "make";
8334     $CPAN::Frontend->myprint("Running $make install\n");
8335   EXCUSE: {
8336         my @e;
8337         if ($self->{make} or $self->{later}) {
8338             # go ahead
8339         } else {
8340             push @e,
8341                 "Make had some problems, won't install";
8342         }
8343
8344         exists $self->{make} and
8345             (
8346              UNIVERSAL::can($self->{make},"failed") ?
8347              $self->{make}->failed :
8348              $self->{make} =~ /^NO/
8349             ) and
8350                 push @e, "Make had returned bad status, install seems impossible";
8351
8352         if (exists $self->{build_dir}) {
8353         } elsif (!@e) {
8354             push @e, "Has no own directory";
8355         }
8356
8357         if (exists $self->{make_test} and
8358             (
8359              UNIVERSAL::can($self->{make_test},"failed") ?
8360              $self->{make_test}->failed :
8361              $self->{make_test} =~ /^NO/
8362             )){
8363             if ($self->{force_update}) {
8364                 $self->{make_test}->text("FAILED but failure ignored because ".
8365                                          "'force' in effect");
8366             } else {
8367                 push @e, "make test had returned bad status, ".
8368                     "won't install without force"
8369             }
8370         }
8371         if (exists $self->{install}) {
8372             if (UNIVERSAL::can($self->{install},"text") ?
8373                 $self->{install}->text eq "YES" :
8374                 $self->{install} =~ /^YES/
8375                ) {
8376                 $CPAN::Frontend->myprint("  Already done\n");
8377                 $CPAN::META->is_installed($self->{build_dir});
8378                 return 1;
8379             } else {
8380                 # comment in Todo on 2006-02-11; maybe retry?
8381                 push @e, "Already tried without success";
8382             }
8383         }
8384
8385         push @e, $self->{later} if $self->{later};
8386
8387         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8388         unless (chdir $self->{build_dir}) {
8389             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8390         }
8391         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8392     }
8393     $self->debug("Changed directory to $self->{build_dir}")
8394         if $CPAN::DEBUG;
8395
8396     if ($^O eq 'MacOS') {
8397         Mac::BuildTools::make_install($self);
8398         return;
8399     }
8400
8401     my $system;
8402     if (my $commandline = $self->prefs->{install}{commandline}) {
8403         $system = $commandline;
8404         $ENV{PERL} = $^X;
8405     } elsif ($self->{modulebuild}) {
8406         my($mbuild_install_build_command) =
8407             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8408                 $CPAN::Config->{mbuild_install_build_command} ?
8409                     $CPAN::Config->{mbuild_install_build_command} :
8410                         $self->_build_command();
8411         $system = sprintf("%s install %s",
8412                           $mbuild_install_build_command,
8413                           $CPAN::Config->{mbuild_install_arg},
8414                          );
8415     } else {
8416         my($make_install_make_command) =
8417             CPAN::HandleConfig->prefs_lookup($self,
8418                                              q{make_install_make_command})
8419                   || $self->_make_command();
8420         $system = sprintf("%s install %s",
8421                           $make_install_make_command,
8422                           $CPAN::Config->{make_install_arg},
8423                          );
8424     }
8425
8426     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8427     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8428                                                 q{build_requires_install_policy});
8429     $brip ||="ask/yes";
8430     my $id = $self->id;
8431     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8432     my $want_install = "yes";
8433     if ($reqtype eq "b") {
8434         if ($brip eq "no") {
8435             $want_install = "no";
8436         } elsif ($brip =~ m|^ask/(.+)|) {
8437             my $default = $1;
8438             $default = "yes" unless $default =~ /^(y|n)/i;
8439             $want_install =
8440                 CPAN::Shell::colorable_makemaker_prompt
8441                       ("$id is just needed temporarily during building or testing. ".
8442                        "Do you want to install it permanently? (Y/n)",
8443                        $default);
8444         }
8445     }
8446     unless ($want_install =~ /^y/i) {
8447         my $is_only = "is only 'build_requires'";
8448         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8449         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8450         delete $self->{force_update};
8451         return;
8452     }
8453     my($pipe) = FileHandle->new("$system $stderr |");
8454     my($makeout) = "";
8455     while (<$pipe>){
8456         print $_; # intentionally NOT use Frontend->myprint because it
8457                   # looks irritating when we markup in color what we
8458                   # just pass through from an external program
8459         $makeout .= $_;
8460     }
8461     $pipe->close;
8462     my $close_ok = $? == 0;
8463     $self->introduce_myself;
8464     if ( $close_ok ) {
8465         $CPAN::Frontend->myprint("  $system -- OK\n");
8466         $CPAN::META->is_installed($self->{build_dir});
8467         $self->{install} = CPAN::Distrostatus->new("YES");
8468     } else {
8469         $self->{install} = CPAN::Distrostatus->new("NO");
8470         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8471         my $mimc =
8472             CPAN::HandleConfig->prefs_lookup($self,
8473                                              q{make_install_make_command});
8474         if (
8475             $makeout =~ /permission/s
8476             && $> > 0
8477             && (
8478                 ! $mimc
8479                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8480                                                               q{make}))
8481                )
8482            ) {
8483             $CPAN::Frontend->myprint(
8484                                      qq{----\n}.
8485                                      qq{  You may have to su }.
8486                                      qq{to root to install the package\n}.
8487                                      qq{  (Or you may want to run something like\n}.
8488                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8489                                      qq{  to raise your permissions.}
8490                                     );
8491         }
8492     }
8493     delete $self->{force_update};
8494     # $DB::single = 1;
8495     $self->store_persistent_state;
8496 }
8497
8498 sub introduce_myself {
8499     my($self) = @_;
8500     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8501 }
8502
8503 #-> sub CPAN::Distribution::dir ;
8504 sub dir {
8505     shift->{build_dir};
8506 }
8507
8508 #-> sub CPAN::Distribution::perldoc ;
8509 sub perldoc {
8510     my($self) = @_;
8511
8512     my($dist) = $self->id;
8513     my $package = $self->called_for;
8514
8515     $self->_display_url( $CPAN::Defaultdocs . $package );
8516 }
8517
8518 #-> sub CPAN::Distribution::_check_binary ;
8519 sub _check_binary {
8520     my ($dist,$shell,$binary) = @_;
8521     my ($pid,$out);
8522
8523     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8524       if $CPAN::DEBUG;
8525
8526     if ($CPAN::META->has_inst("File::Which")) {
8527         return File::Which::which($binary);
8528     } else {
8529         local *README;
8530         $pid = open README, "which $binary|"
8531             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8532         return unless $pid;
8533         while (<README>) {
8534             $out .= $_;
8535         }
8536         close README
8537             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8538                 and return;
8539     }
8540
8541     $CPAN::Frontend->myprint(qq{   + $out \n})
8542       if $CPAN::DEBUG && $out;
8543
8544     return $out;
8545 }
8546
8547 #-> sub CPAN::Distribution::_display_url ;
8548 sub _display_url {
8549     my($self,$url) = @_;
8550     my($res,$saved_file,$pid,$out);
8551
8552     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8553       if $CPAN::DEBUG;
8554
8555     # should we define it in the config instead?
8556     my $html_converter = "html2text";
8557
8558     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8559     my $web_browser_out = $web_browser
8560       ? CPAN::Distribution->_check_binary($self,$web_browser)
8561         : undef;
8562
8563     if ($web_browser_out) {
8564         # web browser found, run the action
8565         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8566         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8567           if $CPAN::DEBUG;
8568         $CPAN::Frontend->myprint(qq{
8569 Displaying URL
8570   $url
8571 with browser $browser
8572 });
8573         $CPAN::Frontend->mysleep(1);
8574         system("$browser $url");
8575         if ($saved_file) { 1 while unlink($saved_file) }
8576     } else {
8577         # web browser not found, let's try text only
8578         my $html_converter_out =
8579           CPAN::Distribution->_check_binary($self,$html_converter);
8580         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8581
8582         if ($html_converter_out ) {
8583             # html2text found, run it
8584             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8585             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8586                 unless defined($saved_file);
8587
8588             local *README;
8589             $pid = open README, "$html_converter $saved_file |"
8590               or $CPAN::Frontend->mydie(qq{
8591 Could not fork '$html_converter $saved_file': $!});
8592             my($fh,$filename);
8593             if ($CPAN::META->has_inst("File::Temp")) {
8594                 $fh = File::Temp->new(
8595                                       dir      => File::Spec->tmpdir,
8596                                       template => 'cpan_htmlconvert_XXXX',
8597                                       suffix => '.txt',
8598                                       unlink => 0,
8599                                      );
8600                 $filename = $fh->filename;
8601             } else {
8602                 $filename = "cpan_htmlconvert_$$.txt";
8603                 $fh = FileHandle->new();
8604                 open $fh, ">$filename" or die;
8605             }
8606             while (<README>) {
8607                 $fh->print($_);
8608             }
8609             close README or
8610                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8611             my $tmpin = $fh->filename;
8612             $CPAN::Frontend->myprint(sprintf(qq{
8613 Run '%s %s' and
8614 saved output to %s\n},
8615                                              $html_converter,
8616                                              $saved_file,
8617                                              $tmpin,
8618                                             )) if $CPAN::DEBUG;
8619             close $fh;
8620             local *FH;
8621             open FH, $tmpin
8622                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8623             my $fh_pager = FileHandle->new;
8624             local($SIG{PIPE}) = "IGNORE";
8625             my $pager = $CPAN::Config->{'pager'} || "cat";
8626             $fh_pager->open("|$pager")
8627                 or $CPAN::Frontend->mydie(qq{
8628 Could not open pager '$pager': $!});
8629             $CPAN::Frontend->myprint(qq{
8630 Displaying URL
8631   $url
8632 with pager "$pager"
8633 });
8634             $CPAN::Frontend->mysleep(1);
8635             $fh_pager->print(<FH>);
8636             $fh_pager->close;
8637         } else {
8638             # coldn't find the web browser or html converter
8639             $CPAN::Frontend->myprint(qq{
8640 You need to install lynx or $html_converter to use this feature.});
8641         }
8642     }
8643 }
8644
8645 #-> sub CPAN::Distribution::_getsave_url ;
8646 sub _getsave_url {
8647     my($dist, $shell, $url) = @_;
8648
8649     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8650       if $CPAN::DEBUG;
8651
8652     my($fh,$filename);
8653     if ($CPAN::META->has_inst("File::Temp")) {
8654         $fh = File::Temp->new(
8655                               dir      => File::Spec->tmpdir,
8656                               template => "cpan_getsave_url_XXXX",
8657                               suffix => ".html",
8658                               unlink => 0,
8659                              );
8660         $filename = $fh->filename;
8661     } else {
8662         $fh = FileHandle->new;
8663         $filename = "cpan_getsave_url_$$.html";
8664     }
8665     my $tmpin = $filename;
8666     if ($CPAN::META->has_usable('LWP')) {
8667         $CPAN::Frontend->myprint("Fetching with LWP:
8668   $url
8669 ");
8670         my $Ua;
8671         CPAN::LWP::UserAgent->config;
8672         eval { $Ua = CPAN::LWP::UserAgent->new; };
8673         if ($@) {
8674             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8675             return;
8676         } else {
8677             my($var);
8678             $Ua->proxy('http', $var)
8679                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8680             $Ua->no_proxy($var)
8681                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8682         }
8683
8684         my $req = HTTP::Request->new(GET => $url);
8685         $req->header('Accept' => 'text/html');
8686         my $res = $Ua->request($req);
8687         if ($res->is_success) {
8688             $CPAN::Frontend->myprint(" + request successful.\n")
8689                 if $CPAN::DEBUG;
8690             print $fh $res->content;
8691             close $fh;
8692             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8693                 if $CPAN::DEBUG;
8694             return $tmpin;
8695         } else {
8696             $CPAN::Frontend->myprint(sprintf(
8697                                              "LWP failed with code[%s], message[%s]\n",
8698                                              $res->code,
8699                                              $res->message,
8700                                             ));
8701             return;
8702         }
8703     } else {
8704         $CPAN::Frontend->mywarn("  LWP not available\n");
8705         return;
8706     }
8707 }
8708
8709 # sub CPAN::Distribution::_build_command
8710 sub _build_command {
8711     my($self) = @_;
8712     if ($^O eq "MSWin32") { # special code needed at least up to
8713                             # Module::Build 0.2611 and 0.2706; a fix
8714                             # in M:B has been promised 2006-01-30
8715         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8716         return "$perl ./Build";
8717     }
8718     return "./Build";
8719 }
8720
8721 #-> sub CPAN::Distribution::reports
8722 sub reports {
8723     my($self) = @_;
8724     my $pathname = $self->id;
8725     $CPAN::Frontend->myprint("Distribution: $pathname\n");
8726
8727     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
8728         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
8729     }
8730     unless ($CPAN::META->has_usable("LWP")) {
8731         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
8732     }
8733     unless ($CPAN::META->has_inst("File::Temp")) {
8734         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
8735     }
8736
8737     my $d = CPAN::DistnameInfo->new($pathname);
8738
8739     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
8740     my $version   = $d->version;   # "0.02"
8741     my $maturity  = $d->maturity;  # "released"
8742     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
8743     my $cpanid    = $d->cpanid;    # "GBARR"
8744     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
8745
8746     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
8747
8748     CPAN::LWP::UserAgent->config;
8749     my $Ua;
8750     eval { $Ua = CPAN::LWP::UserAgent->new; };
8751     if ($@) {
8752         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
8753     }
8754     $CPAN::Frontend->myprint("Fetching '$url'...");
8755     my $resp = $Ua->get($url);
8756     unless ($resp->is_success) {
8757         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
8758     }
8759     $CPAN::Frontend->myprint("DONE\n\n");
8760     my $yaml = $resp->content;
8761     # was fuer ein Umweg!
8762     my $fh = File::Temp->new(
8763                              dir      => File::Spec->tmpdir,
8764                              template => 'cpan_reports_XXXX',
8765                              suffix => '.yaml',
8766                              unlink => 0,
8767                             );
8768     my $tfilename = $fh->filename;
8769     print $fh $yaml;
8770     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
8771     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
8772     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
8773     my %other_versions;
8774     my $this_version_seen;
8775     for my $rep (@$unserialized) {
8776         my $rversion = $rep->{version};
8777         if ($rversion eq $version){
8778             unless ($this_version_seen++) {
8779                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
8780             }
8781             $CPAN::Frontend->myprint
8782                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
8783                          $rep->{archname} eq $Config::Config{archname}?"*":"",
8784                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
8785                          $rep->{action},
8786                          $rep->{perl},
8787                          ucfirst $rep->{osname},
8788                          $rep->{osvers},
8789                          $rep->{archname},
8790                         ));
8791         } else {
8792             $other_versions{$rep->{version}}++;
8793         }
8794     }
8795     unless ($this_version_seen) {
8796         $CPAN::Frontend->myprint("No reports found for version '$version'
8797 Reports for other versions:\n");
8798         for my $v (sort keys %other_versions) {
8799             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
8800         }
8801     }
8802     $url =~ s/\.yaml/.html/;
8803     $CPAN::Frontend->myprint("See $url for details\n");
8804 }
8805
8806 package CPAN::Bundle;
8807 use strict;
8808
8809 sub look {
8810     my $self = shift;
8811     $CPAN::Frontend->myprint($self->as_string);
8812 }
8813
8814 #-> CPAN::Bundle::undelay
8815 sub undelay {
8816     my $self = shift;
8817     delete $self->{later};
8818     for my $c ( $self->contains ) {
8819         my $obj = CPAN::Shell->expandany($c) or next;
8820         $obj->undelay;
8821     }
8822 }
8823
8824 # mark as dirty/clean
8825 #-> sub CPAN::Bundle::color_cmd_tmps ;
8826 sub color_cmd_tmps {
8827     my($self) = shift;
8828     my($depth) = shift || 0;
8829     my($color) = shift || 0;
8830     my($ancestors) = shift || [];
8831     # a module needs to recurse to its cpan_file, a distribution needs
8832     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8833
8834     return if exists $self->{incommandcolor}
8835         && $color==1
8836         && $self->{incommandcolor}==$color;
8837     if ($depth>=$CPAN::MAX_RECURSION){
8838         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8839     }
8840     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8841
8842     for my $c ( $self->contains ) {
8843         my $obj = CPAN::Shell->expandany($c) or next;
8844         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8845         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8846     }
8847     # never reached code?
8848     #if ($color==0) {
8849       #delete $self->{badtestcnt};
8850     #}
8851     $self->{incommandcolor} = $color;
8852 }
8853
8854 #-> sub CPAN::Bundle::as_string ;
8855 sub as_string {
8856     my($self) = @_;
8857     $self->contains;
8858     # following line must be "=", not "||=" because we have a moving target
8859     $self->{INST_VERSION} = $self->inst_version;
8860     return $self->SUPER::as_string;
8861 }
8862
8863 #-> sub CPAN::Bundle::contains ;
8864 sub contains {
8865     my($self) = @_;
8866     my($inst_file) = $self->inst_file || "";
8867     my($id) = $self->id;
8868     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8869     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8870         undef $inst_file;
8871     }
8872     unless ($inst_file) {
8873         # Try to get at it in the cpan directory
8874         $self->debug("no inst_file") if $CPAN::DEBUG;
8875         my $cpan_file;
8876         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8877               $cpan_file = $self->cpan_file;
8878         if ($cpan_file eq "N/A") {
8879             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8880   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8881         }
8882         my $dist = $CPAN::META->instance('CPAN::Distribution',
8883                                          $self->cpan_file);
8884         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8885         $dist->get;
8886         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8887         my($todir) = $CPAN::Config->{'cpan_home'};
8888         my(@me,$from,$to,$me);
8889         @me = split /::/, $self->id;
8890         $me[-1] .= ".pm";
8891         $me = File::Spec->catfile(@me);
8892         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8893         $to = File::Spec->catfile($todir,$me);
8894         File::Path::mkpath(File::Basename::dirname($to));
8895         File::Copy::copy($from, $to)
8896               or Carp::confess("Couldn't copy $from to $to: $!");
8897         $inst_file = $to;
8898     }
8899     my @result;
8900     my $fh = FileHandle->new;
8901     local $/ = "\n";
8902     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8903     my $in_cont = 0;
8904     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8905     while (<$fh>) {
8906         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8907             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8908         next unless $in_cont;
8909         next if /^=/;
8910         s/\#.*//;
8911         next if /^\s+$/;
8912         chomp;
8913         push @result, (split " ", $_, 2)[0];
8914     }
8915     close $fh;
8916     delete $self->{STATUS};
8917     $self->{CONTAINS} = \@result;
8918     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8919     unless (@result) {
8920         $CPAN::Frontend->mywarn(qq{
8921 The bundle file "$inst_file" may be a broken
8922 bundlefile. It seems not to contain any bundle definition.
8923 Please check the file and if it is bogus, please delete it.
8924 Sorry for the inconvenience.
8925 });
8926     }
8927     @result;
8928 }
8929
8930 #-> sub CPAN::Bundle::find_bundle_file
8931 # $where is in local format, $what is in unix format
8932 sub find_bundle_file {
8933     my($self,$where,$what) = @_;
8934     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8935 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8936 ###    my $bu = File::Spec->catfile($where,$what);
8937 ###    return $bu if -f $bu;
8938     my $manifest = File::Spec->catfile($where,"MANIFEST");
8939     unless (-f $manifest) {
8940         require ExtUtils::Manifest;
8941         my $cwd = CPAN::anycwd();
8942         $self->safe_chdir($where);
8943         ExtUtils::Manifest::mkmanifest();
8944         $self->safe_chdir($cwd);
8945     }
8946     my $fh = FileHandle->new($manifest)
8947         or Carp::croak("Couldn't open $manifest: $!");
8948     local($/) = "\n";
8949     my $bundle_filename = $what;
8950     $bundle_filename =~ s|Bundle.*/||;
8951     my $bundle_unixpath;
8952     while (<$fh>) {
8953         next if /^\s*\#/;
8954         my($file) = /(\S+)/;
8955         if ($file =~ m|\Q$what\E$|) {
8956             $bundle_unixpath = $file;
8957             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8958             last;
8959         }
8960         # retry if she managed to have no Bundle directory
8961         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8962     }
8963     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8964         if $bundle_unixpath;
8965     Carp::croak("Couldn't find a Bundle file in $where");
8966 }
8967
8968 # needs to work quite differently from Module::inst_file because of
8969 # cpan_home/Bundle/ directory and the possibility that we have
8970 # shadowing effect. As it makes no sense to take the first in @INC for
8971 # Bundles, we parse them all for $VERSION and take the newest.
8972
8973 #-> sub CPAN::Bundle::inst_file ;
8974 sub inst_file {
8975     my($self) = @_;
8976     my($inst_file);
8977     my(@me);
8978     @me = split /::/, $self->id;
8979     $me[-1] .= ".pm";
8980     my($incdir,$bestv);
8981     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8982         my $bfile = File::Spec->catfile($incdir, @me);
8983         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8984         next unless -f $bfile;
8985         my $foundv = MM->parse_version($bfile);
8986         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8987             $self->{INST_FILE} = $bfile;
8988             $self->{INST_VERSION} = $bestv = $foundv;
8989         }
8990     }
8991     $self->{INST_FILE};
8992 }
8993
8994 #-> sub CPAN::Bundle::inst_version ;
8995 sub inst_version {
8996     my($self) = @_;
8997     $self->inst_file; # finds INST_VERSION as side effect
8998     $self->{INST_VERSION};
8999 }
9000
9001 #-> sub CPAN::Bundle::rematein ;
9002 sub rematein {
9003     my($self,$meth) = @_;
9004     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9005     my($id) = $self->id;
9006     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9007         unless $self->inst_file || $self->cpan_file;
9008     my($s,%fail);
9009     for $s ($self->contains) {
9010         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9011             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9012         if ($type eq 'CPAN::Distribution') {
9013             $CPAN::Frontend->mywarn(qq{
9014 The Bundle }.$self->id.qq{ contains
9015 explicitly a file '$s'.
9016 Going to $meth that.
9017 });
9018             $CPAN::Frontend->mysleep(5);
9019         }
9020         # possibly noisy action:
9021         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9022         my $obj = $CPAN::META->instance($type,$s);
9023         $obj->{reqtype} = $self->{reqtype};
9024         $obj->$meth();
9025     }
9026 }
9027
9028 # If a bundle contains another that contains an xs_file we have here,
9029 # we just don't bother I suppose
9030 #-> sub CPAN::Bundle::xs_file
9031 sub xs_file {
9032     return 0;
9033 }
9034
9035 #-> sub CPAN::Bundle::force ;
9036 sub fforce   { shift->rematein('fforce',@_); }
9037 #-> sub CPAN::Bundle::force ;
9038 sub force   { shift->rematein('force',@_); }
9039 #-> sub CPAN::Bundle::notest ;
9040 sub notest  { shift->rematein('notest',@_); }
9041 #-> sub CPAN::Bundle::get ;
9042 sub get     { shift->rematein('get',@_); }
9043 #-> sub CPAN::Bundle::make ;
9044 sub make    { shift->rematein('make',@_); }
9045 #-> sub CPAN::Bundle::test ;
9046 sub test    {
9047     my $self = shift;
9048     # $self->{badtestcnt} ||= 0;
9049     $self->rematein('test',@_);
9050 }
9051 #-> sub CPAN::Bundle::install ;
9052 sub install {
9053   my $self = shift;
9054   $self->rematein('install',@_);
9055 }
9056 #-> sub CPAN::Bundle::clean ;
9057 sub clean   { shift->rematein('clean',@_); }
9058
9059 #-> sub CPAN::Bundle::uptodate ;
9060 sub uptodate {
9061     my($self) = @_;
9062     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9063     my $c;
9064     foreach $c ($self->contains) {
9065         my $obj = CPAN::Shell->expandany($c);
9066         return 0 unless $obj->uptodate;
9067     }
9068     return 1;
9069 }
9070
9071 #-> sub CPAN::Bundle::readme ;
9072 sub readme  {
9073     my($self) = @_;
9074     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9075 No File found for bundle } . $self->id . qq{\n}), return;
9076     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9077     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9078 }
9079
9080 package CPAN::Module;
9081 use strict;
9082
9083 # Accessors
9084 #-> sub CPAN::Module::userid
9085 sub userid {
9086     my $self = shift;
9087     my $ro = $self->ro;
9088     return unless $ro;
9089     return $ro->{userid} || $ro->{CPAN_USERID};
9090 }
9091 #-> sub CPAN::Module::description
9092 sub description {
9093     my $self = shift;
9094     my $ro = $self->ro or return "";
9095     $ro->{description}
9096 }
9097
9098 #-> sub CPAN::Module::distribution
9099 sub distribution {
9100     my($self) = @_;
9101     CPAN::Shell->expand("Distribution",$self->cpan_file);
9102 }
9103
9104 #-> sub CPAN::Module::undelay
9105 sub undelay {
9106     my $self = shift;
9107     delete $self->{later};
9108     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9109         $dist->undelay;
9110     }
9111 }
9112
9113 # mark as dirty/clean
9114 #-> sub CPAN::Module::color_cmd_tmps ;
9115 sub color_cmd_tmps {
9116     my($self) = shift;
9117     my($depth) = shift || 0;
9118     my($color) = shift || 0;
9119     my($ancestors) = shift || [];
9120     # a module needs to recurse to its cpan_file
9121
9122     return if exists $self->{incommandcolor}
9123         && $color==1
9124         && $self->{incommandcolor}==$color;
9125     return if $color==0 && !$self->{incommandcolor};
9126     if ($color>=1) {
9127         if ( $self->uptodate ) {
9128             $self->{incommandcolor} = $color;
9129             return;
9130         } elsif (my $have_version = $self->available_version) {
9131             # maybe what we have is good enough
9132             if (@$ancestors) {
9133                 my $who_asked_for_me = $ancestors->[-1];
9134                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9135                 if (0) {
9136                 } elsif ($obj->isa("CPAN::Bundle")) {
9137                     # bundles cannot specify a minimum version
9138                     return;
9139                 } elsif ($obj->isa("CPAN::Distribution")) {
9140                     if (my $prereq_pm = $obj->prereq_pm) {
9141                         for my $k (keys %$prereq_pm) {
9142                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9143                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9144                                     $self->{incommandcolor} = $color;
9145                                     return;
9146                                 }
9147                             }
9148                         }
9149                     }
9150                 }
9151             }
9152         }
9153     } else {
9154         $self->{incommandcolor} = $color; # set me before recursion,
9155                                           # so we can break it
9156     }
9157     if ($depth>=$CPAN::MAX_RECURSION){
9158         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9159     }
9160     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9161
9162     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9163         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9164     }
9165     # unreached code?
9166     # if ($color==0) {
9167     #    delete $self->{badtestcnt};
9168     # }
9169     $self->{incommandcolor} = $color;
9170 }
9171
9172 #-> sub CPAN::Module::as_glimpse ;
9173 sub as_glimpse {
9174     my($self) = @_;
9175     my(@m);
9176     my $class = ref($self);
9177     $class =~ s/^CPAN:://;
9178     my $color_on = "";
9179     my $color_off = "";
9180     if (
9181         $CPAN::Shell::COLOR_REGISTERED
9182         &&
9183         $CPAN::META->has_inst("Term::ANSIColor")
9184         &&
9185         $self->description
9186        ) {
9187         $color_on = Term::ANSIColor::color("green");
9188         $color_off = Term::ANSIColor::color("reset");
9189     }
9190     my $uptodateness = " ";
9191     if ($class eq "Bundle") {
9192     } elsif ($self->uptodate) {
9193         $uptodateness = "=";
9194     } elsif ($self->inst_version) {
9195         $uptodateness = "<";
9196     }
9197     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9198                      $class,
9199                      $uptodateness,
9200                      $color_on,
9201                      $self->id,
9202                      $color_off,
9203                      ($self->distribution ?
9204                       $self->distribution->pretty_id :
9205                       $self->cpan_userid
9206                      ),
9207                     );
9208     join "", @m;
9209 }
9210
9211 #-> sub CPAN::Module::dslip_status
9212 sub dslip_status {
9213     my($self) = @_;
9214     my($stat);
9215     # development status
9216     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9217                                               pre-alpha alpha beta released
9218                                               mature standard,;
9219     # support level
9220     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9221                                               developer comp.lang.perl.*
9222                                               none abandoned,;
9223     # language
9224     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9225     # interface
9226     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9227                                               references+ties
9228                                               object-oriented pragma
9229                                               hybrid none,;
9230     # public licence
9231     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9232                                               GPL LGPL
9233                                               BSD Artistic
9234                                               open-source
9235                                               distribution_allowed
9236                                               restricted_distribution
9237                                               no_licence,;
9238     for my $x (qw(d s l i p)) {
9239         $stat->{$x}{' '} = 'unknown';
9240         $stat->{$x}{'?'} = 'unknown';
9241     }
9242     my $ro = $self->ro;
9243     return +{} unless $ro && $ro->{statd};
9244     return {
9245             D  => $ro->{statd},
9246             S  => $ro->{stats},
9247             L  => $ro->{statl},
9248             I  => $ro->{stati},
9249             P  => $ro->{statp},
9250             DV => $stat->{D}{$ro->{statd}},
9251             SV => $stat->{S}{$ro->{stats}},
9252             LV => $stat->{L}{$ro->{statl}},
9253             IV => $stat->{I}{$ro->{stati}},
9254             PV => $stat->{P}{$ro->{statp}},
9255            };
9256 }
9257
9258 #-> sub CPAN::Module::as_string ;
9259 sub as_string {
9260     my($self) = @_;
9261     my(@m);
9262     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9263     my $class = ref($self);
9264     $class =~ s/^CPAN:://;
9265     local($^W) = 0;
9266     push @m, $class, " id = $self->{ID}\n";
9267     my $sprintf = "    %-12s %s\n";
9268     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9269         if $self->description;
9270     my $sprintf2 = "    %-12s %s (%s)\n";
9271     my($userid);
9272     $userid = $self->userid;
9273     if ( $userid ){
9274         my $author;
9275         if ($author = CPAN::Shell->expand('Author',$userid)) {
9276           my $email = "";
9277           my $m; # old perls
9278           if ($m = $author->email) {
9279             $email = " <$m>";
9280           }
9281           push @m, sprintf(
9282                            $sprintf2,
9283                            'CPAN_USERID',
9284                            $userid,
9285                            $author->fullname . $email
9286                           );
9287         }
9288     }
9289     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9290         if $self->cpan_version;
9291     if (my $cpan_file = $self->cpan_file){
9292         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9293         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9294             my $upload_date = $dist->upload_date;
9295             if ($upload_date) {
9296                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9297             }
9298         }
9299     }
9300     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9301     my $dslip = $self->dslip_status;
9302     push @m, sprintf(
9303                      $sprintf3,
9304                      'DSLIP_STATUS',
9305                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9306                     ) if $dslip->{D};
9307     my $local_file = $self->inst_file;
9308     unless ($self->{MANPAGE}) {
9309         my $manpage;
9310         if ($local_file) {
9311             $manpage = $self->manpage_headline($local_file);
9312         } else {
9313             # If we have already untarred it, we should look there
9314             my $dist = $CPAN::META->instance('CPAN::Distribution',
9315                                              $self->cpan_file);
9316             # warn "dist[$dist]";
9317             # mff=manifest file; mfh=manifest handle
9318             my($mff,$mfh);
9319             if (
9320                 $dist->{build_dir}
9321                 and
9322                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9323                 and
9324                 $mfh = FileHandle->new($mff)
9325                ) {
9326                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9327                 my $lfre = $self->id; # local file RE
9328                 $lfre =~ s/::/./g;
9329                 $lfre .= "\\.pm\$";
9330                 my($lfl); # local file file
9331                 local $/ = "\n";
9332                 my(@mflines) = <$mfh>;
9333                 for (@mflines) {
9334                     s/^\s+//;
9335                     s/\s.*//s;
9336                 }
9337                 while (length($lfre)>5 and !$lfl) {
9338                     ($lfl) = grep /$lfre/, @mflines;
9339                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9340                     $lfre =~ s/.+?\.//;
9341                 }
9342                 $lfl =~ s/\s.*//; # remove comments
9343                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9344                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9345                 # warn "lfl_abs[$lfl_abs]";
9346                 if (-f $lfl_abs) {
9347                     $manpage = $self->manpage_headline($lfl_abs);
9348                 }
9349             }
9350         }
9351         $self->{MANPAGE} = $manpage if $manpage;
9352     }
9353     my($item);
9354     for $item (qw/MANPAGE/) {
9355         push @m, sprintf($sprintf, $item, $self->{$item})
9356             if exists $self->{$item};
9357     }
9358     for $item (qw/CONTAINS/) {
9359         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9360             if exists $self->{$item} && @{$self->{$item}};
9361     }
9362     push @m, sprintf($sprintf, 'INST_FILE',
9363                      $local_file || "(not installed)");
9364     push @m, sprintf($sprintf, 'INST_VERSION',
9365                      $self->inst_version) if $local_file;
9366     join "", @m, "\n";
9367 }
9368
9369 #-> sub CPAN::Module::manpage_headline
9370 sub manpage_headline {
9371   my($self,$local_file) = @_;
9372   my(@local_file) = $local_file;
9373   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9374   push @local_file, $local_file;
9375   my(@result,$locf);
9376   for $locf (@local_file) {
9377     next unless -f $locf;
9378     my $fh = FileHandle->new($locf)
9379         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9380     my $inpod = 0;
9381     local $/ = "\n";
9382     while (<$fh>) {
9383       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9384           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9385       next unless $inpod;
9386       next if /^=/;
9387       next if /^\s+$/;
9388       chomp;
9389       push @result, $_;
9390     }
9391     close $fh;
9392     last if @result;
9393   }
9394   for (@result) {
9395       s/^\s+//;
9396       s/\s+$//;
9397   }
9398   join " ", @result;
9399 }
9400
9401 #-> sub CPAN::Module::cpan_file ;
9402 # Note: also inherited by CPAN::Bundle
9403 sub cpan_file {
9404     my $self = shift;
9405     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9406     unless ($self->ro) {
9407         CPAN::Index->reload;
9408     }
9409     my $ro = $self->ro;
9410     if ($ro && defined $ro->{CPAN_FILE}){
9411         return $ro->{CPAN_FILE};
9412     } else {
9413         my $userid = $self->userid;
9414         if ( $userid ) {
9415             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9416                 my $author = $CPAN::META->instance("CPAN::Author",
9417                                                    $userid);
9418                 my $fullname = $author->fullname;
9419                 my $email = $author->email;
9420                 unless (defined $fullname && defined $email) {
9421                     return sprintf("Contact Author %s",
9422                                    $userid,
9423                                   );
9424                 }
9425                 return "Contact Author $fullname <$email>";
9426             } else {
9427                 return "Contact Author $userid (Email address not available)";
9428             }
9429         } else {
9430             return "N/A";
9431         }
9432     }
9433 }
9434
9435 #-> sub CPAN::Module::cpan_version ;
9436 sub cpan_version {
9437     my $self = shift;
9438
9439     my $ro = $self->ro;
9440     unless ($ro) {
9441         # Can happen with modules that are not on CPAN
9442         $ro = {};
9443     }
9444     $ro->{CPAN_VERSION} = 'undef'
9445         unless defined $ro->{CPAN_VERSION};
9446     $ro->{CPAN_VERSION};
9447 }
9448
9449 #-> sub CPAN::Module::force ;
9450 sub force {
9451     my($self) = @_;
9452     $self->{force_update} = 1;
9453 }
9454
9455 #-> sub CPAN::Module::fforce ;
9456 sub fforce {
9457     my($self) = @_;
9458     $self->{force_update} = 2;
9459 }
9460
9461 #-> sub CPAN::Module::notest ;
9462 sub notest {
9463     my($self) = @_;
9464     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
9465     $self->{notest}++;
9466 }
9467
9468 #-> sub CPAN::Module::rematein ;
9469 sub rematein {
9470     my($self,$meth) = @_;
9471     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9472                                      $meth,
9473                                      $self->id));
9474     my $cpan_file = $self->cpan_file;
9475     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9476       $CPAN::Frontend->mywarn(sprintf qq{
9477   The module %s isn\'t available on CPAN.
9478
9479   Either the module has not yet been uploaded to CPAN, or it is
9480   temporary unavailable. Please contact the author to find out
9481   more about the status. Try 'i %s'.
9482 },
9483                               $self->id,
9484                               $self->id,
9485                              );
9486       return;
9487     }
9488     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9489     $pack->called_for($self->id);
9490     if (exists $self->{force_update}){
9491         if ($self->{force_update} == 2) {
9492             $pack->fforce($meth);
9493         } else {
9494             $pack->force($meth);
9495         }
9496     }
9497     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
9498
9499     $pack->{reqtype} ||= "";
9500     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9501                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9502         if ($pack->{reqtype}) {
9503             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9504                 $pack->{reqtype} = $self->{reqtype};
9505                 if (
9506                     exists $pack->{install}
9507                     &&
9508                     (
9509                      UNIVERSAL::can($pack->{install},"failed") ?
9510                      $pack->{install}->failed :
9511                      $pack->{install} =~ /^NO/
9512                     )
9513                    ) {
9514                     delete $pack->{install};
9515                     $CPAN::Frontend->mywarn
9516                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9517                 }
9518             }
9519         } else {
9520             $pack->{reqtype} = $self->{reqtype};
9521         }
9522
9523     my $success = eval {
9524         $pack->$meth();
9525     };
9526     my $err = $@;
9527     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9528     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
9529     delete $self->{force_update};
9530     delete $self->{notest};
9531     if ($err) {
9532         die $err;
9533     }
9534     return $success;
9535 }
9536
9537 #-> sub CPAN::Module::perldoc ;
9538 sub perldoc { shift->rematein('perldoc') }
9539 #-> sub CPAN::Module::readme ;
9540 sub readme  { shift->rematein('readme') }
9541 #-> sub CPAN::Module::look ;
9542 sub look    { shift->rematein('look') }
9543 #-> sub CPAN::Module::cvs_import ;
9544 sub cvs_import { shift->rematein('cvs_import') }
9545 #-> sub CPAN::Module::get ;
9546 sub get     { shift->rematein('get',@_) }
9547 #-> sub CPAN::Module::make ;
9548 sub make    { shift->rematein('make') }
9549 #-> sub CPAN::Module::test ;
9550 sub test   {
9551     my $self = shift;
9552     # $self->{badtestcnt} ||= 0;
9553     $self->rematein('test',@_);
9554 }
9555 #-> sub CPAN::Module::uptodate ;
9556 sub uptodate {
9557     my($self) = @_;
9558     local($_); # protect against a bug in MakeMaker 6.17
9559     my($latest) = $self->cpan_version;
9560     $latest ||= 0;
9561     my($inst_file) = $self->inst_file;
9562     my($have) = 0;
9563     if (defined $inst_file) {
9564         $have = $self->inst_version;
9565     }
9566     local($^W)=0;
9567     if ($inst_file
9568         &&
9569         ! CPAN::Version->vgt($latest, $have)
9570        ) {
9571         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9572                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9573         return 1;
9574     }
9575     return;
9576 }
9577 #-> sub CPAN::Module::install ;
9578 sub install {
9579     my($self) = @_;
9580     my($doit) = 0;
9581     if ($self->uptodate
9582         &&
9583         not exists $self->{force_update}
9584        ) {
9585         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9586                                          $self->id,
9587                                          $self->inst_version,
9588                                         ));
9589     } else {
9590         $doit = 1;
9591     }
9592     my $ro = $self->ro;
9593     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9594         $CPAN::Frontend->mywarn(qq{
9595 \n\n\n     ***WARNING***
9596      The module $self->{ID} has no active maintainer.\n\n\n
9597 });
9598         $CPAN::Frontend->mysleep(5);
9599     }
9600     $self->rematein('install') if $doit;
9601 }
9602 #-> sub CPAN::Module::clean ;
9603 sub clean  { shift->rematein('clean') }
9604
9605 #-> sub CPAN::Module::inst_file ;
9606 sub inst_file {
9607     my($self) = @_;
9608     $self->_file_in_path([@INC]);
9609 }
9610
9611 #-> sub CPAN::Module::available_file ;
9612 sub available_file {
9613     my($self) = @_;
9614     my $sep = $Config::Config{path_sep};
9615     my $perllib = $ENV{PERL5LIB};
9616     $perllib = $ENV{PERLLIB} unless defined $perllib;
9617     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9618     $self->_file_in_path([@perllib,@INC]);
9619 }
9620
9621 #-> sub CPAN::Module::file_in_path ;
9622 sub _file_in_path {
9623     my($self,$path) = @_;
9624     my($dir,@packpath);
9625     @packpath = split /::/, $self->{ID};
9626     $packpath[-1] .= ".pm";
9627     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9628         unshift @packpath, "Term", "ReadLine"; # historical reasons
9629     }
9630     foreach $dir (@$path) {
9631         my $pmfile = File::Spec->catfile($dir,@packpath);
9632         if (-f $pmfile){
9633             return $pmfile;
9634         }
9635     }
9636     return;
9637 }
9638
9639 #-> sub CPAN::Module::xs_file ;
9640 sub xs_file {
9641     my($self) = @_;
9642     my($dir,@packpath);
9643     @packpath = split /::/, $self->{ID};
9644     push @packpath, $packpath[-1];
9645     $packpath[-1] .= "." . $Config::Config{'dlext'};
9646     foreach $dir (@INC) {
9647         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9648         if (-f $xsfile){
9649             return $xsfile;
9650         }
9651     }
9652     return;
9653 }
9654
9655 #-> sub CPAN::Module::inst_version ;
9656 sub inst_version {
9657     my($self) = @_;
9658     my $parsefile = $self->inst_file or return;
9659     my $have = $self->parse_version($parsefile);
9660     $have;
9661 }
9662
9663 #-> sub CPAN::Module::inst_version ;
9664 sub available_version {
9665     my($self) = @_;
9666     my $parsefile = $self->available_file or return;
9667     my $have = $self->parse_version($parsefile);
9668     $have;
9669 }
9670
9671 #-> sub CPAN::Module::parse_version ;
9672 sub parse_version {
9673     my($self,$parsefile) = @_;
9674     my $have = MM->parse_version($parsefile);
9675     $have = "undef" unless defined $have && length $have;
9676     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9677     $have =~ s/ $//; # trailing whitespace happens all the time
9678
9679     $have = CPAN::Version->readable($have);
9680
9681     $have =~ s/\s*//g; # stringify to float around floating point issues
9682     $have; # no stringify needed, \s* above matches always
9683 }
9684
9685 #-> sub CPAN::Module::reports
9686 sub reports {
9687     my($self) = @_;
9688     $self->distribution->reports;
9689 }
9690
9691 package CPAN;
9692 use strict;
9693
9694 1;
9695
9696
9697 __END__
9698
9699 =head1 NAME
9700
9701 CPAN - query, download and build perl modules from CPAN sites
9702
9703 =head1 SYNOPSIS
9704
9705 Interactive mode:
9706
9707   perl -MCPAN -e shell
9708
9709 --or--
9710
9711   cpan
9712
9713 Basic commands:
9714
9715   # Modules:
9716
9717   cpan> install Acme::Meta                       # in the shell
9718
9719   CPAN::Shell->install("Acme::Meta");            # in perl
9720
9721   # Distributions:
9722
9723   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9724
9725   CPAN::Shell->
9726     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9727
9728   # module objects:
9729
9730   $mo = CPAN::Shell->expandany($mod);
9731   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9732
9733   # distribution objects:
9734
9735   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9736   $do = CPAN::Shell->expandany($distro);         # same thing
9737   $do = CPAN::Shell->expand("Distribution",
9738                             $distro);            # same thing
9739
9740 =head1 DESCRIPTION
9741
9742 The CPAN module automates or at least simplifies the make and install
9743 of perl modules and extensions. It includes some primitive searching
9744 capabilities and knows how to use Net::FTP or LWP or some external
9745 download clients to fetch the distributions from the net.
9746
9747 These are fetched from one or more of the mirrored CPAN (Comprehensive
9748 Perl Archive Network) sites and unpacked in a dedicated directory.
9749
9750 The CPAN module also supports the concept of named and versioned
9751 I<bundles> of modules. Bundles simplify the handling of sets of
9752 related modules. See Bundles below.
9753
9754 The package contains a session manager and a cache manager. The
9755 session manager keeps track of what has been fetched, built and
9756 installed in the current session. The cache manager keeps track of the
9757 disk space occupied by the make processes and deletes excess space
9758 according to a simple FIFO mechanism.
9759
9760 All methods provided are accessible in a programmer style and in an
9761 interactive shell style.
9762
9763 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9764
9765 The interactive mode is entered by running
9766
9767     perl -MCPAN -e shell
9768
9769 or
9770
9771     cpan
9772
9773 which puts you into a readline interface. If C<Term::ReadKey> and
9774 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9775 it supports both history and command completion.
9776
9777 Once you are on the command line, type C<h> to get a one page help
9778 screen and the rest should be self-explanatory.
9779
9780 The function call C<shell> takes two optional arguments, one is the
9781 prompt, the second is the default initial command line (the latter
9782 only works if a real ReadLine interface module is installed).
9783
9784 The most common uses of the interactive modes are
9785
9786 =over 2
9787
9788 =item Searching for authors, bundles, distribution files and modules
9789
9790 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9791 for each of the four categories and another, C<i> for any of the
9792 mentioned four. Each of the four entities is implemented as a class
9793 with slightly differing methods for displaying an object.
9794
9795 Arguments you pass to these commands are either strings exactly matching
9796 the identification string of an object or regular expressions that are
9797 then matched case-insensitively against various attributes of the
9798 objects. The parser recognizes a regular expression only if you
9799 enclose it between two slashes.
9800
9801 The principle is that the number of found objects influences how an
9802 item is displayed. If the search finds one item, the result is
9803 displayed with the rather verbose method C<as_string>, but if we find
9804 more than one, we display each object with the terse method
9805 C<as_glimpse>.
9806
9807 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9808
9809 These commands take any number of arguments and investigate what is
9810 necessary to perform the action. If the argument is a distribution
9811 file name (recognized by embedded slashes), it is processed. If it is
9812 a module, CPAN determines the distribution file in which this module
9813 is included and processes that, following any dependencies named in
9814 the module's META.yml or Makefile.PL (this behavior is controlled by
9815 the configuration parameter C<prerequisites_policy>.)
9816
9817 C<get> downloads a distribution file and untars or unzips it, C<make>
9818 builds it, C<test> runs the test suite, and C<install> installs it.
9819
9820 Any C<make> or C<test> are run unconditionally. An
9821
9822   install <distribution_file>
9823
9824 also is run unconditionally. But for
9825
9826   install <module>
9827
9828 CPAN checks if an install is actually needed for it and prints
9829 I<module up to date> in the case that the distribution file containing
9830 the module doesn't need to be updated.
9831
9832 CPAN also keeps track of what it has done within the current session
9833 and doesn't try to build a package a second time regardless if it
9834 succeeded or not. It does not repeat a test run if the test
9835 has been run successfully before. Same for install runs.
9836
9837 The C<force> pragma may precede another command (currently: C<get>,
9838 C<make>, C<test>, or C<install>) and executes the command from scratch
9839 and tries to continue in case of some errors. See the section below on
9840 the C<force> and the C<fforce> pragma.
9841
9842 The C<notest> pragma may be used to skip the test part in the build
9843 process.
9844
9845 Example:
9846
9847     cpan> notest install Tk
9848
9849 A C<clean> command results in a
9850
9851   make clean
9852
9853 being executed within the distribution file's working directory.
9854
9855 =item C<readme>, C<perldoc>, C<look> module or distribution
9856
9857 C<readme> displays the README file of the associated distribution.
9858 C<Look> gets and untars (if not yet done) the distribution file,
9859 changes to the appropriate directory and opens a subshell process in
9860 that directory. C<perldoc> displays the pod documentation of the
9861 module in html or plain text format.
9862
9863 =item C<ls> author
9864
9865 =item C<ls> globbing_expression
9866
9867 The first form lists all distribution files in and below an author's
9868 CPAN directory as they are stored in the CHECKUMS files distributed on
9869 CPAN. The listing goes recursive into all subdirectories.
9870
9871 The second form allows to limit or expand the output with shell
9872 globbing as in the following examples:
9873
9874           ls JV/make*
9875           ls GSAR/*make*
9876           ls */*make*
9877
9878 The last example is very slow and outputs extra progress indicators
9879 that break the alignment of the result.
9880
9881 Note that globbing only lists directories explicitly asked for, for
9882 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9883 regarded as a bug and may be changed in future versions.
9884
9885 =item C<failed>
9886
9887 The C<failed> command reports all distributions that failed on one of
9888 C<make>, C<test> or C<install> for some reason in the currently
9889 running shell session.
9890
9891 =item Persistence between sessions
9892
9893 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9894 the internal state of all modules is written to disk after each step.
9895 The files contain a signature of the currently running perl version
9896 for later perusal.
9897
9898 If the configurations variable C<build_dir_reuse> is set to a true
9899 value, then CPAN.pm reads the collected YAML files. If the stored
9900 signature matches the currently running perl the stored state is
9901 loaded into memory such that effectively persistence between sessions
9902 is established.
9903
9904 =item The C<force> and the C<fforce> pragma
9905
9906 To speed things up in complex installation scenarios, CPAN.pm keeps
9907 track of what it has already done and refuses to do some things a
9908 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9909 A C<test> is only repeated if the previous test was unsuccessful. The
9910 diagnostic message when CPAN.pm refuses to do something a second time
9911 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9912 something similar. Another situation where CPAN refuses to act is an
9913 C<install> if the according C<test> was not successful.
9914
9915 In all these cases, the user can override the goatish behaviour by
9916 prepending the command with the word force, for example:
9917
9918   cpan> force get Foo
9919   cpan> force make AUTHOR/Bar-3.14.tar.gz
9920   cpan> force test Baz
9921   cpan> force install Acme::Meta
9922
9923 Each I<forced> command is executed with the according part of its
9924 memory erased.
9925
9926 The C<fforce> pragma is a variant that emulates a C<force get> which
9927 erases the entire memory followed by the action specified, effectively
9928 restarting the whole get/make/test/install procedure from scratch.
9929
9930 =item Lockfile
9931
9932 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9933 Batch jobs can run without a lockfile and do not disturb each other.
9934
9935 The shell offers to run in I<degraded mode> when another process is
9936 holding the lockfile. This is an experimental feature that is not yet
9937 tested very well. This second shell then does not write the history
9938 file, does not use the metadata file and has a different prompt.
9939
9940 =item Signals
9941
9942 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9943 in the cpan-shell it is intended that you can press C<^C> anytime and
9944 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9945 to clean up and leave the shell loop. You can emulate the effect of a
9946 SIGTERM by sending two consecutive SIGINTs, which usually means by
9947 pressing C<^C> twice.
9948
9949 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9950 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9951 Build.PL> subprocess.
9952
9953 =back
9954
9955 =head2 CPAN::Shell
9956
9957 The commands that are available in the shell interface are methods in
9958 the package CPAN::Shell. If you enter the shell command, all your
9959 input is split by the Text::ParseWords::shellwords() routine which
9960 acts like most shells do. The first word is being interpreted as the
9961 method to be called and the rest of the words are treated as arguments
9962 to this method. Continuation lines are supported if a line ends with a
9963 literal backslash.
9964
9965 =head2 autobundle
9966
9967 C<autobundle> writes a bundle file into the
9968 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9969 a list of all modules that are both available from CPAN and currently
9970 installed within @INC. The name of the bundle file is based on the
9971 current date and a counter.
9972
9973 =head2 hosts
9974
9975 Note: this feature is still in alpha state and may change in future
9976 versions of CPAN.pm
9977
9978 This commands provides a statistical overview over recent download
9979 activities. The data for this is collected in the YAML file
9980 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9981 configured or YAML not installed, then no stats are provided.
9982
9983 =head2 mkmyconfig
9984
9985 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9986 directory so that you can save your own preferences instead of the
9987 system wide ones.
9988
9989 =head2 recompile
9990
9991 recompile() is a very special command in that it takes no argument and
9992 runs the make/test/install cycle with brute force over all installed
9993 dynamically loadable extensions (aka XS modules) with 'force' in
9994 effect. The primary purpose of this command is to finish a network
9995 installation. Imagine, you have a common source tree for two different
9996 architectures. You decide to do a completely independent fresh
9997 installation. You start on one architecture with the help of a Bundle
9998 file produced earlier. CPAN installs the whole Bundle for you, but
9999 when you try to repeat the job on the second architecture, CPAN
10000 responds with a C<"Foo up to date"> message for all modules. So you
10001 invoke CPAN's recompile on the second architecture and you're done.
10002
10003 Another popular use for C<recompile> is to act as a rescue in case your
10004 perl breaks binary compatibility. If one of the modules that CPAN uses
10005 is in turn depending on binary compatibility (so you cannot run CPAN
10006 commands), then you should try the CPAN::Nox module for recovery.
10007
10008 =head2 report Bundle|Distribution|Module
10009
10010 The C<report> command temporarily turns on the C<test_report> config
10011 variable, then runs the C<force test> command with the given
10012 arguments. The C<force> pragma is used to re-run the tests and repeat
10013 every step that might have failed before.
10014
10015 =head2 upgrade [Module|/Regex/]...
10016
10017 The C<upgrade> command first runs an C<r> command with the given
10018 arguments and then installs the newest versions of all modules that
10019 were listed by that.
10020
10021 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10022
10023 Although it may be considered internal, the class hierarchy does matter
10024 for both users and programmer. CPAN.pm deals with above mentioned four
10025 classes, and all those classes share a set of methods. A classical
10026 single polymorphism is in effect. A metaclass object registers all
10027 objects of all kinds and indexes them with a string. The strings
10028 referencing objects have a separated namespace (well, not completely
10029 separated):
10030
10031          Namespace                         Class
10032
10033    words containing a "/" (slash)      Distribution
10034     words starting with Bundle::          Bundle
10035           everything else            Module or Author
10036
10037 Modules know their associated Distribution objects. They always refer
10038 to the most recent official release. Developers may mark their releases
10039 as unstable development versions (by inserting an underbar into the
10040 module version number which will also be reflected in the distribution
10041 name when you run 'make dist'), so the really hottest and newest
10042 distribution is not always the default.  If a module Foo circulates
10043 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10044 way to install version 1.23 by saying
10045
10046     install Foo
10047
10048 This would install the complete distribution file (say
10049 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10050 like to install version 1.23_90, you need to know where the
10051 distribution file resides on CPAN relative to the authors/id/
10052 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10053 so you would have to say
10054
10055     install BAR/Foo-1.23_90.tar.gz
10056
10057 The first example will be driven by an object of the class
10058 CPAN::Module, the second by an object of class CPAN::Distribution.
10059
10060 =head2 Integrating local directories
10061
10062 Note: this feature is still in alpha state and may change in future
10063 versions of CPAN.pm
10064
10065 Distribution objects are normally distributions from the CPAN, but
10066 there is a slightly degenerate case for Distribution objects, too, of
10067 projects held on the local disk. These distribution objects have the
10068 same name as the local directory and end with a dot. A dot by itself
10069 is also allowed for the current directory at the time CPAN.pm was
10070 used. All actions such as C<make>, C<test>, and C<install> are applied
10071 directly to that directory. This gives the command C<cpan .> an
10072 interesting touch: while the normal mantra of installing a CPAN module
10073 without CPAN.pm is one of
10074
10075     perl Makefile.PL                 perl Build.PL
10076            ( go and get prerequisites )
10077     make                             ./Build
10078     make test                        ./Build test
10079     make install                     ./Build install
10080
10081 the command C<cpan .> does all of this at once. It figures out which
10082 of the two mantras is appropriate, fetches and installs all
10083 prerequisites, cares for them recursively and finally finishes the
10084 installation of the module in the current directory, be it a CPAN
10085 module or not.
10086
10087 The typical usage case is for private modules or working copies of
10088 projects from remote repositories on the local disk.
10089
10090 =head1 CONFIGURATION
10091
10092 When the CPAN module is used for the first time, a configuration
10093 dialog tries to determine a couple of site specific options. The
10094 result of the dialog is stored in a hash reference C< $CPAN::Config >
10095 in a file CPAN/Config.pm.
10096
10097 The default values defined in the CPAN/Config.pm file can be
10098 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10099 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10100 added to the search path of the CPAN module before the use() or
10101 require() statements. The mkmyconfig command writes this file for you.
10102
10103 The C<o conf> command has various bells and whistles:
10104
10105 =over
10106
10107 =item completion support
10108
10109 If you have a ReadLine module installed, you can hit TAB at any point
10110 of the commandline and C<o conf> will offer you completion for the
10111 built-in subcommands and/or config variable names.
10112
10113 =item displaying some help: o conf help
10114
10115 Displays a short help
10116
10117 =item displaying current values: o conf [KEY]
10118
10119 Displays the current value(s) for this config variable. Without KEY
10120 displays all subcommands and config variables.
10121
10122 Example:
10123
10124   o conf shell
10125
10126 =item changing of scalar values: o conf KEY VALUE
10127
10128 Sets the config variable KEY to VALUE. The empty string can be
10129 specified as usual in shells, with C<''> or C<"">
10130
10131 Example:
10132
10133   o conf wget /usr/bin/wget
10134
10135 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10136
10137 If a config variable name ends with C<list>, it is a list. C<o conf
10138 KEY shift> removes the first element of the list, C<o conf KEY pop>
10139 removes the last element of the list. C<o conf KEYS unshift LIST>
10140 prepends a list of values to the list, C<o conf KEYS push LIST>
10141 appends a list of valued to the list.
10142
10143 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10144 splice command.
10145
10146 Finally, any other list of arguments is taken as a new list value for
10147 the KEY variable discarding the previous value.
10148
10149 Examples:
10150
10151   o conf urllist unshift http://cpan.dev.local/CPAN
10152   o conf urllist splice 3 1
10153   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10154
10155 =item reverting to saved: o conf defaults
10156
10157 Reverts all config variables to the state in the saved config file.
10158
10159 =item saving the config: o conf commit
10160
10161 Saves all config variables to the current config file (CPAN/Config.pm
10162 or CPAN/MyConfig.pm that was loaded at start).
10163
10164 =back
10165
10166 The configuration dialog can be started any time later again by
10167 issuing the command C< o conf init > in the CPAN shell. A subset of
10168 the configuration dialog can be run by issuing C<o conf init WORD>
10169 where WORD is any valid config variable or a regular expression.
10170
10171 =head2 Config Variables
10172
10173 Currently the following keys in the hash reference $CPAN::Config are
10174 defined:
10175
10176   applypatch         path to external prg
10177   auto_commit        commit all changes to config variables to disk
10178   build_cache        size of cache for directories to build modules
10179   build_dir          locally accessible directory to build modules
10180   build_dir_reuse    boolean if distros in build_dir are persistent
10181   build_requires_install_policy
10182                      to install or not to install when a module is
10183                      only needed for building. yes|no|ask/yes|ask/no
10184   bzip2              path to external prg
10185   cache_metadata     use serializer to cache metadata
10186   commands_quote     prefered character to use for quoting external
10187                      commands when running them. Defaults to double
10188                      quote on Windows, single tick everywhere else;
10189                      can be set to space to disable quoting
10190   check_sigs         if signatures should be verified
10191   colorize_debug     Term::ANSIColor attributes for debugging output
10192   colorize_output    boolean if Term::ANSIColor should colorize output
10193   colorize_print     Term::ANSIColor attributes for normal output
10194   colorize_warn      Term::ANSIColor attributes for warnings
10195   commandnumber_in_prompt
10196                      boolean if you want to see current command number
10197   cpan_home          local directory reserved for this package
10198   curl               path to external prg
10199   dontload_hash      DEPRECATED
10200   dontload_list      arrayref: modules in the list will not be
10201                      loaded by the CPAN::has_inst() routine
10202   ftp                path to external prg
10203   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10204   ftp_proxy          proxy host for ftp requests
10205   getcwd             see below
10206   gpg                path to external prg
10207   gzip               location of external program gzip
10208   histfile           file to maintain history between sessions
10209   histsize           maximum number of lines to keep in histfile
10210   http_proxy         proxy host for http requests
10211   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10212                      after this many seconds inactivity. Set to 0 to
10213                      never break.
10214   index_expire       after this many days refetch index files
10215   inhibit_startup_message
10216                      if true, does not print the startup message
10217   keep_source_where  directory in which to keep the source (if we do)
10218   lynx               path to external prg
10219   make               location of external make program
10220   make_arg           arguments that should always be passed to 'make'
10221   make_install_make_command
10222                      the make command for running 'make install', for
10223                      example 'sudo make'
10224   make_install_arg   same as make_arg for 'make install'
10225   makepl_arg         arguments passed to 'perl Makefile.PL'
10226   mbuild_arg         arguments passed to './Build'
10227   mbuild_install_arg arguments passed to './Build install'
10228   mbuild_install_build_command
10229                      command to use instead of './Build' when we are
10230                      in the install stage, for example 'sudo ./Build'
10231   mbuildpl_arg       arguments passed to 'perl Build.PL'
10232   ncftp              path to external prg
10233   ncftpget           path to external prg
10234   no_proxy           don't proxy to these hosts/domains (comma separated list)
10235   pager              location of external program more (or any pager)
10236   password           your password if you CPAN server wants one
10237   patch              path to external prg
10238   prefer_installer   legal values are MB and EUMM: if a module comes
10239                      with both a Makefile.PL and a Build.PL, use the
10240                      former (EUMM) or the latter (MB); if the module
10241                      comes with only one of the two, that one will be
10242                      used in any case
10243   prerequisites_policy
10244                      what to do if you are missing module prerequisites
10245                      ('follow' automatically, 'ask' me, or 'ignore')
10246   prefs_dir          local directory to store per-distro build options
10247   proxy_user         username for accessing an authenticating proxy
10248   proxy_pass         password for accessing an authenticating proxy
10249   randomize_urllist  add some randomness to the sequence of the urllist
10250   scan_cache         controls scanning of cache ('atstart' or 'never')
10251   shell              your favorite shell
10252   show_upload_date   boolean if commands should try to determine upload date
10253   tar                location of external program tar
10254   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10255                      (and nonsense for characters outside latin range)
10256   term_ornaments     boolean to turn ReadLine ornamenting on/off
10257   test_report        email test reports (if CPAN::Reporter is installed)
10258   unzip              location of external program unzip
10259   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10260   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10261   username           your username if you CPAN server wants one
10262   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10263   wget               path to external prg
10264   yaml_module        which module to use to read/write YAML files
10265
10266 You can set and query each of these options interactively in the cpan
10267 shell with the C<o conf> or the C<o conf init> command as specified below.
10268
10269 =over 2
10270
10271 =item C<o conf E<lt>scalar optionE<gt>>
10272
10273 prints the current value of the I<scalar option>
10274
10275 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10276
10277 Sets the value of the I<scalar option> to I<value>
10278
10279 =item C<o conf E<lt>list optionE<gt>>
10280
10281 prints the current value of the I<list option> in MakeMaker's
10282 neatvalue format.
10283
10284 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10285
10286 shifts or pops the array in the I<list option> variable
10287
10288 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10289
10290 works like the corresponding perl commands.
10291
10292 =item interactive editing: o conf init [MATCH|LIST]
10293
10294 Runs an interactive configuration dialog for matching variables.
10295 Without argument runs the dialog over all supported config variables.
10296 To specify a MATCH the argument must be enclosed by slashes.
10297
10298 Examples:
10299
10300   o conf init ftp_passive ftp_proxy
10301   o conf init /color/
10302
10303 Note: this method of setting config variables often provides more
10304 explanation about the functioning of a variable than the manpage.
10305
10306 =back
10307
10308 =head2 CPAN::anycwd($path): Note on config variable getcwd
10309
10310 CPAN.pm changes the current working directory often and needs to
10311 determine its own current working directory. Per default it uses
10312 Cwd::cwd but if this doesn't work on your system for some reason,
10313 alternatives can be configured according to the following table:
10314
10315 =over 4
10316
10317 =item cwd
10318
10319 Calls Cwd::cwd
10320
10321 =item getcwd
10322
10323 Calls Cwd::getcwd
10324
10325 =item fastcwd
10326
10327 Calls Cwd::fastcwd
10328
10329 =item backtickcwd
10330
10331 Calls the external command cwd.
10332
10333 =back
10334
10335 =head2 Note on the format of the urllist parameter
10336
10337 urllist parameters are URLs according to RFC 1738. We do a little
10338 guessing if your URL is not compliant, but if you have problems with
10339 C<file> URLs, please try the correct format. Either:
10340
10341     file://localhost/whatever/ftp/pub/CPAN/
10342
10343 or
10344
10345     file:///home/ftp/pub/CPAN/
10346
10347 =head2 The urllist parameter has CD-ROM support
10348
10349 The C<urllist> parameter of the configuration table contains a list of
10350 URLs that are to be used for downloading. If the list contains any
10351 C<file> URLs, CPAN always tries to get files from there first. This
10352 feature is disabled for index files. So the recommendation for the
10353 owner of a CD-ROM with CPAN contents is: include your local, possibly
10354 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10355
10356   o conf urllist push file://localhost/CDROM/CPAN
10357
10358 CPAN.pm will then fetch the index files from one of the CPAN sites
10359 that come at the beginning of urllist. It will later check for each
10360 module if there is a local copy of the most recent version.
10361
10362 Another peculiarity of urllist is that the site that we could
10363 successfully fetch the last file from automatically gets a preference
10364 token and is tried as the first site for the next request. So if you
10365 add a new site at runtime it may happen that the previously preferred
10366 site will be tried another time. This means that if you want to disallow
10367 a site for the next transfer, it must be explicitly removed from
10368 urllist.
10369
10370 =head2 Maintaining the urllist parameter
10371
10372 If you have YAML.pm (or some other YAML module configured in
10373 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10374 about recent downloads. You can view the statistics with the C<hosts>
10375 command or inspect them directly by looking into the C<FTPstats.yml>
10376 file in your C<cpan_home> directory.
10377
10378 To get some interesting statistics it is recommended to set the
10379 C<randomize_urllist> parameter that introduces some amount of
10380 randomness into the URL selection.
10381
10382 =head2 The C<requires> and C<build_requires> dependency declarations
10383
10384 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10385 a distribution are treated differently depending on the config
10386 variable C<build_requires_install_policy>. By setting
10387 C<build_requires_install_policy> to C<no> such a module is not being
10388 installed. It is only built and tested and then kept in the list of
10389 tested but uninstalled modules. As such it is available during the
10390 build of the dependent module by integrating the path to the
10391 C<blib/arch> and C<blib/lib> directories in the environment variable
10392 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10393 both modules declared as C<requires> and those declared as
10394 C<build_requires> are treated alike. By setting to C<ask/yes> or
10395 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10396
10397 =head2 Configuration for individual distributions (I<Distroprefs>)
10398
10399 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10400 still considered beta quality)
10401
10402 Distributions on the CPAN usually behave according to what we call the
10403 CPAN mantra. Or since the event of Module::Build we should talk about
10404 two mantras:
10405
10406     perl Makefile.PL     perl Build.PL
10407     make                 ./Build
10408     make test            ./Build test
10409     make install         ./Build install
10410
10411 But some modules cannot be built with this mantra. They try to get
10412 some extra data from the user via the environment, extra arguments or
10413 interactively thus disturbing the installation of large bundles like
10414 Phalanx100 or modules with many dependencies like Plagger.
10415
10416 The distroprefs system of C<CPAN.pm> addresses this problem by
10417 allowing the user to specify extra informations and recipes in YAML
10418 files to either
10419
10420 =over
10421
10422 =item
10423
10424 pass additional arguments to one of the four commands,
10425
10426 =item
10427
10428 set environment variables
10429
10430 =item
10431
10432 instantiate an Expect object that reads from the console, waits for
10433 some regular expressions and enters some answers
10434
10435 =item
10436
10437 temporarily override assorted C<CPAN.pm> configuration variables
10438
10439 =item
10440
10441 disable the installation of an object altogether
10442
10443 =back
10444
10445 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10446 distribution in the C<distroprefs/> directory for examples.
10447
10448 =head2 Filenames
10449
10450 The YAML files themselves must have the C<.yml> extension, all other
10451 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10452 Storable> below). The containing directory can be specified in
10453 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10454 prefs_dir> in the CPAN shell to set and activate the distroprefs
10455 system.
10456
10457 Every YAML file may contain arbitrary documents according to the YAML
10458 specification and every single document is treated as an entity that
10459 can specify the treatment of a single distribution.
10460
10461 The names of the files can be picked freely, C<CPAN.pm> always reads
10462 all files (in alphabetical order) and takes the key C<match> (see
10463 below in I<Language Specs>) as a hashref containing match criteria
10464 that determine if the current distribution matches the YAML document
10465 or not.
10466
10467 =head2 Fallback Data::Dumper and Storable
10468
10469 If neither your configured C<yaml_module> nor YAML.pm is installed
10470 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10471 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10472 directory. These files are expected to contain one or more hashrefs.
10473 For Data::Dumper generated files, this is expected to be done with by
10474 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10475 with the command
10476
10477     ysh < somefile.yml > somefile.dd
10478
10479 For Storable files the rule is that they must be constructed such that
10480 C<Storable::retrieve(file)> returns an array reference and the array
10481 elements represent one distropref object each. The conversion from
10482 YAML would look like so:
10483
10484     perl -MYAML=LoadFile -MStorable=nstore -e '
10485         @y=LoadFile(shift);
10486         nstore(\@y, shift)' somefile.yml somefile.st
10487
10488 In bootstrapping situations it is usually sufficient to translate only
10489 a few YAML files to Data::Dumper for the crucial modules like
10490 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10491 over Data::Dumper, remember to pull out a Storable version that writes
10492 an older format than all the other Storable versions that will need to
10493 read them.
10494
10495 =head2 Blueprint
10496
10497 The following example contains all supported keywords and structures
10498 with the exception of C<eexpect> which can be used instead of
10499 C<expect>.
10500
10501   ---
10502   comment: "Demo"
10503   match:
10504     module: "Dancing::Queen"
10505     distribution: "^CHACHACHA/Dancing-"
10506     perl: "/usr/local/cariba-perl/bin/perl"
10507     perlconfig:
10508       archname: "freebsd"
10509   disabled: 1
10510   cpanconfig:
10511     make: gmake
10512   pl:
10513     args:
10514       - "--somearg=specialcase"
10515
10516     env: {}
10517
10518     expect:
10519       - "Which is your favorite fruit"
10520       - "apple\n"
10521
10522   make:
10523     args:
10524       - all
10525       - extra-all
10526
10527     env: {}
10528
10529     expect: []
10530
10531     commendline: "echo SKIPPING make"
10532
10533   test:
10534     args: []
10535
10536     env: {}
10537
10538     expect: []
10539
10540   install:
10541     args: []
10542
10543     env:
10544       WANT_TO_INSTALL: YES
10545
10546     expect:
10547       - "Do you really want to install"
10548       - "y\n"
10549
10550   patches:
10551     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10552
10553
10554 =head2 Language Specs
10555
10556 Every YAML document represents a single hash reference. The valid keys
10557 in this hash are as follows:
10558
10559 =over
10560
10561 =item comment [scalar]
10562
10563 A comment
10564
10565 =item cpanconfig [hash]
10566
10567 Temporarily override assorted C<CPAN.pm> configuration variables.
10568
10569 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10570 C<make>, C<make_install_make_command>, C<prefer_installer>,
10571 C<test_report>. Please report as a bug when you need another one
10572 supported.
10573
10574 =item disabled [boolean]
10575
10576 Specifies that this distribution shall not be processed at all.
10577
10578 =item goto [string]
10579
10580 The canonical name of a delegate distribution that shall be installed
10581 instead. Useful when a new version, although it tests OK itself,
10582 breaks something else or a developer release or a fork is already
10583 uploaded that is better than the last released version.
10584
10585 =item install [hash]
10586
10587 Processing instructions for the C<make install> or C<./Build install>
10588 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10589
10590 =item make [hash]
10591
10592 Processing instructions for the C<make> or C<./Build> phase of the
10593 CPAN mantra. See below under I<Processiong Instructions>.
10594
10595 =item match [hash]
10596
10597 A hashref with one or more of the keys C<distribution>, C<modules>,
10598 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10599 specific CPAN distribution or installation.
10600
10601 The corresponding values are interpreted as regular expressions. The
10602 C<distribution> related one will be matched against the canonical
10603 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10604
10605 The C<module> related one will be matched against I<all> modules
10606 contained in the distribution until one module matches.
10607
10608 The C<perl> related one will be matched against C<$^X>.
10609
10610 The value associated with C<perlconfig> is itself a hashref that is
10611 matched against corresponding values in the C<%Config::Config> hash
10612 living in the C< Config.pm > module.
10613
10614 If more than one restriction of C<module>, C<distribution>, and
10615 C<perl> is specified, the results of the separately computed match
10616 values must all match. If this is the case then the hashref
10617 represented by the YAML document is returned as the preference
10618 structure for the current distribution.
10619
10620 =item patches [array]
10621
10622 An array of patches on CPAN or on the local disk to be applied in
10623 order via the external patch program. If the value for the C<-p>
10624 parameter is C<0> or C<1> is determined by reading the patch
10625 beforehand.
10626
10627 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10628 knows about it B<and> a patch is written by the C<makepatch> program,
10629 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10630 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10631 distribution.
10632
10633 =item pl [hash]
10634
10635 Processing instructions for the C<perl Makefile.PL> or C<perl
10636 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10637 Instructions>.
10638
10639 =item test [hash]
10640
10641 Processing instructions for the C<make test> or C<./Build test> phase
10642 of the CPAN mantra. See below under I<Processiong Instructions>.
10643
10644 =back
10645
10646 =head2 Processing Instructions
10647
10648 =over
10649
10650 =item args [array]
10651
10652 Arguments to be added to the command line
10653
10654 =item commandline
10655
10656 A full commandline that will be executed as it stands by a system
10657 call. During the execution the environment variable PERL will is set
10658 to $^X. If C<commandline> is specified, the content of C<args> is not
10659 used.
10660
10661 =item eexpect [hash]
10662
10663 Extended C<expect>. This is a hash reference with three allowed keys,
10664 C<mode>, C<timeout>, and C<talk>.
10665
10666 C<mode> may have the values C<deterministic> for the case where all
10667 questions come in the order written down and C<anyorder> for the case
10668 where the questions may come in any order. The default mode is
10669 C<deterministic>.
10670
10671 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10672 OK. In the case of a C<mode=deterministic> the timeout denotes the
10673 timeout per question, in the case of C<mode=anyorder> it denotes the
10674 timeout per byte received from the stream or questions.
10675
10676 C<talk> is a reference to an array that contains alternating questions
10677 and answers. Questions are regular expressions and answers are literal
10678 strings. The Expect module will then watch the stream coming from the
10679 execution of the external program (C<perl Makefile.PL>, C<perl
10680 Build.PL>, C<make>, etc.).
10681
10682 In the case of C<mode=deterministic> the CPAN.pm will inject the
10683 according answer as soon as the stream matches the regular expression.
10684 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10685 soon as the timeout is reached for the next byte in the input stream.
10686 In the latter case it removes the according question/answer pair from
10687 the array, so if you want to answer the question C<Do you really want
10688 to do that> several times, then it must be included in the array at
10689 least as often as you want this answer to be given.
10690
10691 =item env [hash]
10692
10693 Environment variables to be set during the command
10694
10695 =item expect [array]
10696
10697 C<< expect: <array> >> is a short notation for
10698
10699   eexpect:
10700     mode: deterministic
10701     timeout: 15
10702     talk: <array>
10703
10704 =back
10705
10706 =head2 Schema verification with C<Kwalify>
10707
10708 If you have the C<Kwalify> module installed (which is part of the
10709 Bundle::CPANxxl), then all your distroprefs files are checked for
10710 syntactical correctness.
10711
10712 =head2 Example Distroprefs Files
10713
10714 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10715 are really just examples and should not be used without care because
10716 they cannot fit everybody's purpose. After all the authors of the
10717 packages that ask questions had a need to ask, so you should watch
10718 their questions and adjust the examples to your environment and your
10719 needs. You have beend warned:-)
10720
10721 =head1 PROGRAMMER'S INTERFACE
10722
10723 If you do not enter the shell, the available shell commands are both
10724 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10725 functions in the calling package (C<install(...)>).  Before calling low-level
10726 commands it makes sense to initialize components of CPAN you need, e.g.:
10727
10728   CPAN::HandleConfig->load;
10729   CPAN::Shell::setup_output;
10730   CPAN::Index->reload;
10731
10732 High-level commands do such initializations automatically.
10733
10734 There's currently only one class that has a stable interface -
10735 CPAN::Shell. All commands that are available in the CPAN shell are
10736 methods of the class CPAN::Shell. Each of the commands that produce
10737 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10738 the IDs of all modules within the list.
10739
10740 =over 2
10741
10742 =item expand($type,@things)
10743
10744 The IDs of all objects available within a program are strings that can
10745 be expanded to the corresponding real objects with the
10746 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10747 list of CPAN::Module objects according to the C<@things> arguments
10748 given. In scalar context it only returns the first element of the
10749 list.
10750
10751 =item expandany(@things)
10752
10753 Like expand, but returns objects of the appropriate type, i.e.
10754 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10755 CPAN::Distribution objects for distributions. Note: it does not expand
10756 to CPAN::Author objects.
10757
10758 =item Programming Examples
10759
10760 This enables the programmer to do operations that combine
10761 functionalities that are available in the shell.
10762
10763     # install everything that is outdated on my disk:
10764     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10765
10766     # install my favorite programs if necessary:
10767     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10768         CPAN::Shell->install($mod);
10769     }
10770
10771     # list all modules on my disk that have no VERSION number
10772     for $mod (CPAN::Shell->expand("Module","/./")){
10773         next unless $mod->inst_file;
10774         # MakeMaker convention for undefined $VERSION:
10775         next unless $mod->inst_version eq "undef";
10776         print "No VERSION in ", $mod->id, "\n";
10777     }
10778
10779     # find out which distribution on CPAN contains a module:
10780     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10781
10782 Or if you want to write a cronjob to watch The CPAN, you could list
10783 all modules that need updating. First a quick and dirty way:
10784
10785     perl -e 'use CPAN; CPAN::Shell->r;'
10786
10787 If you don't want to get any output in the case that all modules are
10788 up to date, you can parse the output of above command for the regular
10789 expression //modules are up to date// and decide to mail the output
10790 only if it doesn't match. Ick?
10791
10792 If you prefer to do it more in a programmer style in one single
10793 process, maybe something like this suits you better:
10794
10795   # list all modules on my disk that have newer versions on CPAN
10796   for $mod (CPAN::Shell->expand("Module","/./")){
10797     next unless $mod->inst_file;
10798     next if $mod->uptodate;
10799     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10800         $mod->id, $mod->inst_version, $mod->cpan_version;
10801   }
10802
10803 If that gives you too much output every day, you maybe only want to
10804 watch for three modules. You can write
10805
10806   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10807
10808 as the first line instead. Or you can combine some of the above
10809 tricks:
10810
10811   # watch only for a new mod_perl module
10812   $mod = CPAN::Shell->expand("Module","mod_perl");
10813   exit if $mod->uptodate;
10814   # new mod_perl arrived, let me know all update recommendations
10815   CPAN::Shell->r;
10816
10817 =back
10818
10819 =head2 Methods in the other Classes
10820
10821 =over 4
10822
10823 =item CPAN::Author::as_glimpse()
10824
10825 Returns a one-line description of the author
10826
10827 =item CPAN::Author::as_string()
10828
10829 Returns a multi-line description of the author
10830
10831 =item CPAN::Author::email()
10832
10833 Returns the author's email address
10834
10835 =item CPAN::Author::fullname()
10836
10837 Returns the author's name
10838
10839 =item CPAN::Author::name()
10840
10841 An alias for fullname
10842
10843 =item CPAN::Bundle::as_glimpse()
10844
10845 Returns a one-line description of the bundle
10846
10847 =item CPAN::Bundle::as_string()
10848
10849 Returns a multi-line description of the bundle
10850
10851 =item CPAN::Bundle::clean()
10852
10853 Recursively runs the C<clean> method on all items contained in the bundle.
10854
10855 =item CPAN::Bundle::contains()
10856
10857 Returns a list of objects' IDs contained in a bundle. The associated
10858 objects may be bundles, modules or distributions.
10859
10860 =item CPAN::Bundle::force($method,@args)
10861
10862 Forces CPAN to perform a task that it normally would have refused to
10863 do. Force takes as arguments a method name to be called and any number
10864 of additional arguments that should be passed to the called method.
10865 The internals of the object get the needed changes so that CPAN.pm
10866 does not refuse to take the action. The C<force> is passed recursively
10867 to all contained objects. See also the section above on the C<force>
10868 and the C<fforce> pragma.
10869
10870 =item CPAN::Bundle::get()
10871
10872 Recursively runs the C<get> method on all items contained in the bundle
10873
10874 =item CPAN::Bundle::inst_file()
10875
10876 Returns the highest installed version of the bundle in either @INC or
10877 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10878 CPAN::Module::inst_file.
10879
10880 =item CPAN::Bundle::inst_version()
10881
10882 Like CPAN::Bundle::inst_file, but returns the $VERSION
10883
10884 =item CPAN::Bundle::uptodate()
10885
10886 Returns 1 if the bundle itself and all its members are uptodate.
10887
10888 =item CPAN::Bundle::install()
10889
10890 Recursively runs the C<install> method on all items contained in the bundle
10891
10892 =item CPAN::Bundle::make()
10893
10894 Recursively runs the C<make> method on all items contained in the bundle
10895
10896 =item CPAN::Bundle::readme()
10897
10898 Recursively runs the C<readme> method on all items contained in the bundle
10899
10900 =item CPAN::Bundle::test()
10901
10902 Recursively runs the C<test> method on all items contained in the bundle
10903
10904 =item CPAN::Distribution::as_glimpse()
10905
10906 Returns a one-line description of the distribution
10907
10908 =item CPAN::Distribution::as_string()
10909
10910 Returns a multi-line description of the distribution
10911
10912 =item CPAN::Distribution::author
10913
10914 Returns the CPAN::Author object of the maintainer who uploaded this
10915 distribution
10916
10917 =item CPAN::Distribution::clean()
10918
10919 Changes to the directory where the distribution has been unpacked and
10920 runs C<make clean> there.
10921
10922 =item CPAN::Distribution::containsmods()
10923
10924 Returns a list of IDs of modules contained in a distribution file.
10925 Only works for distributions listed in the 02packages.details.txt.gz
10926 file. This typically means that only the most recent version of a
10927 distribution is covered.
10928
10929 =item CPAN::Distribution::cvs_import()
10930
10931 Changes to the directory where the distribution has been unpacked and
10932 runs something like
10933
10934     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10935
10936 there.
10937
10938 =item CPAN::Distribution::dir()
10939
10940 Returns the directory into which this distribution has been unpacked.
10941
10942 =item CPAN::Distribution::force($method,@args)
10943
10944 Forces CPAN to perform a task that it normally would have refused to
10945 do. Force takes as arguments a method name to be called and any number
10946 of additional arguments that should be passed to the called method.
10947 The internals of the object get the needed changes so that CPAN.pm
10948 does not refuse to take the action. See also the section above on the
10949 C<force> and the C<fforce> pragma.
10950
10951 =item CPAN::Distribution::get()
10952
10953 Downloads the distribution from CPAN and unpacks it. Does nothing if
10954 the distribution has already been downloaded and unpacked within the
10955 current session.
10956
10957 =item CPAN::Distribution::install()
10958
10959 Changes to the directory where the distribution has been unpacked and
10960 runs the external command C<make install> there. If C<make> has not
10961 yet been run, it will be run first. A C<make test> will be issued in
10962 any case and if this fails, the install will be canceled. The
10963 cancellation can be avoided by letting C<force> run the C<install> for
10964 you.
10965
10966 This install method has only the power to install the distribution if
10967 there are no dependencies in the way. To install an object and all of
10968 its dependencies, use CPAN::Shell->install.
10969
10970 Note that install() gives no meaningful return value. See uptodate().
10971
10972 =item CPAN::Distribution::install_tested()
10973
10974 Install all the distributions that have been tested sucessfully but
10975 not yet installed. See also C<is_tested>.
10976
10977 =item CPAN::Distribution::isa_perl()
10978
10979 Returns 1 if this distribution file seems to be a perl distribution.
10980 Normally this is derived from the file name only, but the index from
10981 CPAN can contain a hint to achieve a return value of true for other
10982 filenames too.
10983
10984 =item CPAN::Distribution::is_tested()
10985
10986 List all the distributions that have been tested sucessfully but not
10987 yet installed. See also C<install_tested>.
10988
10989 =item CPAN::Distribution::look()
10990
10991 Changes to the directory where the distribution has been unpacked and
10992 opens a subshell there. Exiting the subshell returns.
10993
10994 =item CPAN::Distribution::make()
10995
10996 First runs the C<get> method to make sure the distribution is
10997 downloaded and unpacked. Changes to the directory where the
10998 distribution has been unpacked and runs the external commands C<perl
10999 Makefile.PL> or C<perl Build.PL> and C<make> there.
11000
11001 =item CPAN::Distribution::perldoc()
11002
11003 Downloads the pod documentation of the file associated with a
11004 distribution (in html format) and runs it through the external
11005 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11006 isn't available, it converts it to plain text with external
11007 command html2text and runs it through the pager specified
11008 in C<$CPAN::Config->{pager}>
11009
11010 =item CPAN::Distribution::prefs()
11011
11012 Returns the hash reference from the first matching YAML file that the
11013 user has deposited in the C<prefs_dir/> directory. The first
11014 succeeding match wins. The files in the C<prefs_dir/> are processed
11015 alphabetically and the canonical distroname (e.g.
11016 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11017 stored in the $root->{match}{distribution} attribute value.
11018 Additionally all module names contained in a distribution are matched
11019 agains the regular expressions in the $root->{match}{module} attribute
11020 value. The two match values are ANDed together. Each of the two
11021 attributes are optional.
11022
11023 =item CPAN::Distribution::prereq_pm()
11024
11025 Returns the hash reference that has been announced by a distribution
11026 as the the C<requires> and C<build_requires> elements. These can be
11027 declared either by the C<META.yml> (if authoritative) or can be
11028 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11029 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11030 a comment in the produced C<Makefile>. I<Note>: this method only works
11031 after an attempt has been made to C<make> the distribution. Returns
11032 undef otherwise.
11033
11034 =item CPAN::Distribution::readme()
11035
11036 Downloads the README file associated with a distribution and runs it
11037 through the pager specified in C<$CPAN::Config->{pager}>.
11038
11039 =item CPAN::Distribution::reports()
11040
11041 Downloads report data for this distribution from cpantesters.perl.org
11042 and displays a subset of them.
11043
11044 =item CPAN::Distribution::read_yaml()
11045
11046 Returns the content of the META.yml of this distro as a hashref. Note:
11047 works only after an attempt has been made to C<make> the distribution.
11048 Returns undef otherwise. Also returns undef if the content of META.yml
11049 is not authoritative. (The rules about what exactly makes the content
11050 authoritative are still in flux.)
11051
11052 =item CPAN::Distribution::test()
11053
11054 Changes to the directory where the distribution has been unpacked and
11055 runs C<make test> there.
11056
11057 =item CPAN::Distribution::uptodate()
11058
11059 Returns 1 if all the modules contained in the distribution are
11060 uptodate. Relies on containsmods.
11061
11062 =item CPAN::Index::force_reload()
11063
11064 Forces a reload of all indices.
11065
11066 =item CPAN::Index::reload()
11067
11068 Reloads all indices if they have not been read for more than
11069 C<$CPAN::Config->{index_expire}> days.
11070
11071 =item CPAN::InfoObj::dump()
11072
11073 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11074 inherit this method. It prints the data structure associated with an
11075 object. Useful for debugging. Note: the data structure is considered
11076 internal and thus subject to change without notice.
11077
11078 =item CPAN::Module::as_glimpse()
11079
11080 Returns a one-line description of the module in four columns: The
11081 first column contains the word C<Module>, the second column consists
11082 of one character: an equals sign if this module is already installed
11083 and uptodate, a less-than sign if this module is installed but can be
11084 upgraded, and a space if the module is not installed. The third column
11085 is the name of the module and the fourth column gives maintainer or
11086 distribution information.
11087
11088 =item CPAN::Module::as_string()
11089
11090 Returns a multi-line description of the module
11091
11092 =item CPAN::Module::clean()
11093
11094 Runs a clean on the distribution associated with this module.
11095
11096 =item CPAN::Module::cpan_file()
11097
11098 Returns the filename on CPAN that is associated with the module.
11099
11100 =item CPAN::Module::cpan_version()
11101
11102 Returns the latest version of this module available on CPAN.
11103
11104 =item CPAN::Module::cvs_import()
11105
11106 Runs a cvs_import on the distribution associated with this module.
11107
11108 =item CPAN::Module::description()
11109
11110 Returns a 44 character description of this module. Only available for
11111 modules listed in The Module List (CPAN/modules/00modlist.long.html
11112 or 00modlist.long.txt.gz)
11113
11114 =item CPAN::Module::distribution()
11115
11116 Returns the CPAN::Distribution object that contains the current
11117 version of this module.
11118
11119 =item CPAN::Module::dslip_status()
11120
11121 Returns a hash reference. The keys of the hash are the letters C<D>,
11122 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11123 language, interface and public licence respectively. The data for the
11124 DSLIP status are collected by pause.perl.org when authors register
11125 their namespaces. The values of the 5 hash elements are one-character
11126 words whose meaning is described in the table below. There are also 5
11127 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11128 verbose value of the 5 status variables.
11129
11130 Where the 'DSLIP' characters have the following meanings:
11131
11132   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11133     i   - Idea, listed to gain consensus or as a placeholder
11134     c   - under construction but pre-alpha (not yet released)
11135     a/b - Alpha/Beta testing
11136     R   - Released
11137     M   - Mature (no rigorous definition)
11138     S   - Standard, supplied with Perl 5
11139
11140   S - Support Level:
11141     m   - Mailing-list
11142     d   - Developer
11143     u   - Usenet newsgroup comp.lang.perl.modules
11144     n   - None known, try comp.lang.perl.modules
11145     a   - abandoned; volunteers welcome to take over maintainance
11146
11147   L - Language Used:
11148     p   - Perl-only, no compiler needed, should be platform independent
11149     c   - C and perl, a C compiler will be needed
11150     h   - Hybrid, written in perl with optional C code, no compiler needed
11151     +   - C++ and perl, a C++ compiler will be needed
11152     o   - perl and another language other than C or C++
11153
11154   I - Interface Style
11155     f   - plain Functions, no references used
11156     h   - hybrid, object and function interfaces available
11157     n   - no interface at all (huh?)
11158     r   - some use of unblessed References or ties
11159     O   - Object oriented using blessed references and/or inheritance
11160
11161   P - Public License
11162     p   - Standard-Perl: user may choose between GPL and Artistic
11163     g   - GPL: GNU General Public License
11164     l   - LGPL: "GNU Lesser General Public License" (previously known as
11165           "GNU Library General Public License")
11166     b   - BSD: The BSD License
11167     a   - Artistic license alone
11168     o   - open source: appoved by www.opensource.org
11169     d   - allows distribution without restrictions
11170     r   - restricted distribtion
11171     n   - no license at all
11172
11173 =item CPAN::Module::force($method,@args)
11174
11175 Forces CPAN to perform a task that it normally would have refused to
11176 do. Force takes as arguments a method name to be called and any number
11177 of additional arguments that should be passed to the called method.
11178 The internals of the object get the needed changes so that CPAN.pm
11179 does not refuse to take the action. See also the section above on the
11180 C<force> and the C<fforce> pragma.
11181
11182 =item CPAN::Module::get()
11183
11184 Runs a get on the distribution associated with this module.
11185
11186 =item CPAN::Module::inst_file()
11187
11188 Returns the filename of the module found in @INC. The first file found
11189 is reported just like perl itself stops searching @INC when it finds a
11190 module.
11191
11192 =item CPAN::Module::available_file()
11193
11194 Returns the filename of the module found in PERL5LIB or @INC. The
11195 first file found is reported. The advantage of this method over
11196 C<inst_file> is that modules that have been tested but not yet
11197 installed are included because PERL5LIB keeps track of tested modules.
11198
11199 =item CPAN::Module::inst_version()
11200
11201 Returns the version number of the installed module in readable format.
11202
11203 =item CPAN::Module::available_version()
11204
11205 Returns the version number of the available module in readable format.
11206
11207 =item CPAN::Module::install()
11208
11209 Runs an C<install> on the distribution associated with this module.
11210
11211 =item CPAN::Module::look()
11212
11213 Changes to the directory where the distribution associated with this
11214 module has been unpacked and opens a subshell there. Exiting the
11215 subshell returns.
11216
11217 =item CPAN::Module::make()
11218
11219 Runs a C<make> on the distribution associated with this module.
11220
11221 =item CPAN::Module::manpage_headline()
11222
11223 If module is installed, peeks into the module's manpage, reads the
11224 headline and returns it. Moreover, if the module has been downloaded
11225 within this session, does the equivalent on the downloaded module even
11226 if it is not installed.
11227
11228 =item CPAN::Module::perldoc()
11229
11230 Runs a C<perldoc> on this module.
11231
11232 =item CPAN::Module::readme()
11233
11234 Runs a C<readme> on the distribution associated with this module.
11235
11236 =item CPAN::Module::reports()
11237
11238 Calls the reports() method on the associated distribution object.
11239
11240 =item CPAN::Module::test()
11241
11242 Runs a C<test> on the distribution associated with this module.
11243
11244 =item CPAN::Module::uptodate()
11245
11246 Returns 1 if the module is installed and up-to-date.
11247
11248 =item CPAN::Module::userid()
11249
11250 Returns the author's ID of the module.
11251
11252 =back
11253
11254 =head2 Cache Manager
11255
11256 Currently the cache manager only keeps track of the build directory
11257 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11258 deletes complete directories below C<build_dir> as soon as the size of
11259 all directories there gets bigger than $CPAN::Config->{build_cache}
11260 (in MB). The contents of this cache may be used for later
11261 re-installations that you intend to do manually, but will never be
11262 trusted by CPAN itself. This is due to the fact that the user might
11263 use these directories for building modules on different architectures.
11264
11265 There is another directory ($CPAN::Config->{keep_source_where}) where
11266 the original distribution files are kept. This directory is not
11267 covered by the cache manager and must be controlled by the user. If
11268 you choose to have the same directory as build_dir and as
11269 keep_source_where directory, then your sources will be deleted with
11270 the same fifo mechanism.
11271
11272 =head2 Bundles
11273
11274 A bundle is just a perl module in the namespace Bundle:: that does not
11275 define any functions or methods. It usually only contains documentation.
11276
11277 It starts like a perl module with a package declaration and a $VERSION
11278 variable. After that the pod section looks like any other pod with the
11279 only difference being that I<one special pod section> exists starting with
11280 (verbatim):
11281
11282         =head1 CONTENTS
11283
11284 In this pod section each line obeys the format
11285
11286         Module_Name [Version_String] [- optional text]
11287
11288 The only required part is the first field, the name of a module
11289 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11290 of the line is optional. The comment part is delimited by a dash just
11291 as in the man page header.
11292
11293 The distribution of a bundle should follow the same convention as
11294 other distributions.
11295
11296 Bundles are treated specially in the CPAN package. If you say 'install
11297 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11298 the modules in the CONTENTS section of the pod. You can install your
11299 own Bundles locally by placing a conformant Bundle file somewhere into
11300 your @INC path. The autobundle() command which is available in the
11301 shell interface does that for you by including all currently installed
11302 modules in a snapshot bundle file.
11303
11304 =head1 PREREQUISITES
11305
11306 If you have a local mirror of CPAN and can access all files with
11307 "file:" URLs, then you only need a perl better than perl5.003 to run
11308 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11309 required for non-UNIX systems or if your nearest CPAN site is
11310 associated with a URL that is not C<ftp:>.
11311
11312 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11313 implemented for an external ftp command or for an external lynx
11314 command.
11315
11316 =head1 UTILITIES
11317
11318 =head2 Finding packages and VERSION
11319
11320 This module presumes that all packages on CPAN
11321
11322 =over 2
11323
11324 =item *
11325
11326 declare their $VERSION variable in an easy to parse manner. This
11327 prerequisite can hardly be relaxed because it consumes far too much
11328 memory to load all packages into the running program just to determine
11329 the $VERSION variable. Currently all programs that are dealing with
11330 version use something like this
11331
11332     perl -MExtUtils::MakeMaker -le \
11333         'print MM->parse_version(shift)' filename
11334
11335 If you are author of a package and wonder if your $VERSION can be
11336 parsed, please try the above method.
11337
11338 =item *
11339
11340 come as compressed or gzipped tarfiles or as zip files and contain a
11341 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11342 without much enthusiasm).
11343
11344 =back
11345
11346 =head2 Debugging
11347
11348 The debugging of this module is a bit complex, because we have
11349 interferences of the software producing the indices on CPAN, of the
11350 mirroring process on CPAN, of packaging, of configuration, of
11351 synchronicity, and of bugs within CPAN.pm.
11352
11353 For debugging the code of CPAN.pm itself in interactive mode some more
11354 or less useful debugging aid can be turned on for most packages within
11355 CPAN.pm with one of
11356
11357 =over 2
11358
11359 =item o debug package...
11360
11361 sets debug mode for packages.
11362
11363 =item o debug -package...
11364
11365 unsets debug mode for packages.
11366
11367 =item o debug all
11368
11369 turns debugging on for all packages.
11370
11371 =item o debug number
11372
11373 =back
11374
11375 which sets the debugging packages directly. Note that C<o debug 0>
11376 turns debugging off.
11377
11378 What seems quite a successful strategy is the combination of C<reload
11379 cpan> and the debugging switches. Add a new debug statement while
11380 running in the shell and then issue a C<reload cpan> and see the new
11381 debugging messages immediately without losing the current context.
11382
11383 C<o debug> without an argument lists the valid package names and the
11384 current set of packages in debugging mode. C<o debug> has built-in
11385 completion support.
11386
11387 For debugging of CPAN data there is the C<dump> command which takes
11388 the same arguments as make/test/install and outputs each object's
11389 Data::Dumper dump. If an argument looks like a perl variable and
11390 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11391 Data::Dumper directly.
11392
11393 =head2 Floppy, Zip, Offline Mode
11394
11395 CPAN.pm works nicely without network too. If you maintain machines
11396 that are not networked at all, you should consider working with file:
11397 URLs. Of course, you have to collect your modules somewhere first. So
11398 you might use CPAN.pm to put together all you need on a networked
11399 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11400 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11401 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11402 with this floppy. See also below the paragraph about CD-ROM support.
11403
11404 =head2 Basic Utilities for Programmers
11405
11406 =over 2
11407
11408 =item has_inst($module)
11409
11410 Returns true if the module is installed. Used to load all modules into
11411 the running CPAN.pm which are considered optional. The config variable
11412 C<dontload_list> can be used to intercept the C<has_inst()> call such
11413 that an optional module is not loaded despite being available. For
11414 example the following command will prevent that C<YAML.pm> is being
11415 loaded:
11416
11417     cpan> o conf dontload_list push YAML
11418
11419 See the source for details.
11420
11421 =item has_usable($module)
11422
11423 Returns true if the module is installed and is in a usable state. Only
11424 useful for a handful of modules that are used internally. See the
11425 source for details.
11426
11427 =item instance($module)
11428
11429 The constructor for all the singletons used to represent modules,
11430 distributions, authors and bundles. If the object already exists, this
11431 method returns the object, otherwise it calls the constructor.
11432
11433 =back
11434
11435 =head1 SECURITY
11436
11437 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11438 install foreign, unmasked, unsigned code on your machine. We compare
11439 to a checksum that comes from the net just as the distribution file
11440 itself. But we try to make it easy to add security on demand:
11441
11442 =head2 Cryptographically signed modules
11443
11444 Since release 1.77 CPAN.pm has been able to verify cryptographically
11445 signed module distributions using Module::Signature.  The CPAN modules
11446 can be signed by their authors, thus giving more security.  The simple
11447 unsigned MD5 checksums that were used before by CPAN protect mainly
11448 against accidental file corruption.
11449
11450 You will need to have Module::Signature installed, which in turn
11451 requires that you have at least one of Crypt::OpenPGP module or the
11452 command-line F<gpg> tool installed.
11453
11454 You will also need to be able to connect over the Internet to the public
11455 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11456
11457 The configuration parameter check_sigs is there to turn signature
11458 checking on or off.
11459
11460 =head1 EXPORT
11461
11462 Most functions in package CPAN are exported per default. The reason
11463 for this is that the primary use is intended for the cpan shell or for
11464 one-liners.
11465
11466 =head1 ENVIRONMENT
11467
11468 When the CPAN shell enters a subshell via the look command, it sets
11469 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11470 already set.
11471
11472 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11473
11474 When the config variable ftp_passive is set, all downloads will be run
11475 with the environment variable FTP_PASSIVE set to this value. This is
11476 in general a good idea as it influences both Net::FTP and LWP based
11477 connections. The same effect can be achieved by starting the cpan
11478 shell with this environment variable set. For Net::FTP alone, one can
11479 also always set passive mode by running libnetcfg.
11480
11481 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11482
11483 Populating a freshly installed perl with my favorite modules is pretty
11484 easy if you maintain a private bundle definition file. To get a useful
11485 blueprint of a bundle definition file, the command autobundle can be used
11486 on the CPAN shell command line. This command writes a bundle definition
11487 file for all modules that are installed for the currently running perl
11488 interpreter. It's recommended to run this command only once and from then
11489 on maintain the file manually under a private name, say
11490 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11491
11492     cpan> install Bundle::my_bundle
11493
11494 then answer a few questions and then go out for a coffee.
11495
11496 Maintaining a bundle definition file means keeping track of two
11497 things: dependencies and interactivity. CPAN.pm sometimes fails on
11498 calculating dependencies because not all modules define all MakeMaker
11499 attributes correctly, so a bundle definition file should specify
11500 prerequisites as early as possible. On the other hand, it's a bit
11501 annoying that many distributions need some interactive configuring. So
11502 what I try to accomplish in my private bundle file is to have the
11503 packages that need to be configured early in the file and the gentle
11504 ones later, so I can go out after a few minutes and leave CPAN.pm
11505 untended.
11506
11507 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11508
11509 Thanks to Graham Barr for contributing the following paragraphs about
11510 the interaction between perl, and various firewall configurations. For
11511 further information on firewalls, it is recommended to consult the
11512 documentation that comes with the ncftp program. If you are unable to
11513 go through the firewall with a simple Perl setup, it is very likely
11514 that you can configure ncftp so that it works for your firewall.
11515
11516 =head2 Three basic types of firewalls
11517
11518 Firewalls can be categorized into three basic types.
11519
11520 =over 4
11521
11522 =item http firewall
11523
11524 This is where the firewall machine runs a web server and to access the
11525 outside world you must do it via the web server. If you set environment
11526 variables like http_proxy or ftp_proxy to a values beginning with http://
11527 or in your web browser you have to set proxy information then you know
11528 you are running an http firewall.
11529
11530 To access servers outside these types of firewalls with perl (even for
11531 ftp) you will need to use LWP.
11532
11533 =item ftp firewall
11534
11535 This where the firewall machine runs an ftp server. This kind of
11536 firewall will only let you access ftp servers outside the firewall.
11537 This is usually done by connecting to the firewall with ftp, then
11538 entering a username like "user@outside.host.com"
11539
11540 To access servers outside these type of firewalls with perl you
11541 will need to use Net::FTP.
11542
11543 =item One way visibility
11544
11545 I say one way visibility as these firewalls try to make themselves look
11546 invisible to the users inside the firewall. An FTP data connection is
11547 normally created by sending the remote server your IP address and then
11548 listening for the connection. But the remote server will not be able to
11549 connect to you because of the firewall. So for these types of firewall
11550 FTP connections need to be done in a passive mode.
11551
11552 There are two that I can think off.
11553
11554 =over 4
11555
11556 =item SOCKS
11557
11558 If you are using a SOCKS firewall you will need to compile perl and link
11559 it with the SOCKS library, this is what is normally called a 'socksified'
11560 perl. With this executable you will be able to connect to servers outside
11561 the firewall as if it is not there.
11562
11563 =item IP Masquerade
11564
11565 This is the firewall implemented in the Linux kernel, it allows you to
11566 hide a complete network behind one IP address. With this firewall no
11567 special compiling is needed as you can access hosts directly.
11568
11569 For accessing ftp servers behind such firewalls you usually need to
11570 set the environment variable C<FTP_PASSIVE> or the config variable
11571 ftp_passive to a true value.
11572
11573 =back
11574
11575 =back
11576
11577 =head2 Configuring lynx or ncftp for going through a firewall
11578
11579 If you can go through your firewall with e.g. lynx, presumably with a
11580 command such as
11581
11582     /usr/local/bin/lynx -pscott:tiger
11583
11584 then you would configure CPAN.pm with the command
11585
11586     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11587
11588 That's all. Similarly for ncftp or ftp, you would configure something
11589 like
11590
11591     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11592
11593 Your mileage may vary...
11594
11595 =head1 FAQ
11596
11597 =over 4
11598
11599 =item 1)
11600
11601 I installed a new version of module X but CPAN keeps saying,
11602 I have the old version installed
11603
11604 Most probably you B<do> have the old version installed. This can
11605 happen if a module installs itself into a different directory in the
11606 @INC path than it was previously installed. This is not really a
11607 CPAN.pm problem, you would have the same problem when installing the
11608 module manually. The easiest way to prevent this behaviour is to add
11609 the argument C<UNINST=1> to the C<make install> call, and that is why
11610 many people add this argument permanently by configuring
11611
11612   o conf make_install_arg UNINST=1
11613
11614 =item 2)
11615
11616 So why is UNINST=1 not the default?
11617
11618 Because there are people who have their precise expectations about who
11619 may install where in the @INC path and who uses which @INC array. In
11620 fine tuned environments C<UNINST=1> can cause damage.
11621
11622 =item 3)
11623
11624 I want to clean up my mess, and install a new perl along with
11625 all modules I have. How do I go about it?
11626
11627 Run the autobundle command for your old perl and optionally rename the
11628 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11629 with the Configure option prefix, e.g.
11630
11631     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11632
11633 Install the bundle file you produced in the first step with something like
11634
11635     cpan> install Bundle::mybundle
11636
11637 and you're done.
11638
11639 =item 4)
11640
11641 When I install bundles or multiple modules with one command
11642 there is too much output to keep track of.
11643
11644 You may want to configure something like
11645
11646   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11647   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11648
11649 so that STDOUT is captured in a file for later inspection.
11650
11651
11652 =item 5)
11653
11654 I am not root, how can I install a module in a personal directory?
11655
11656 First of all, you will want to use your own configuration, not the one
11657 that your root user installed. If you do not have permission to write
11658 in the cpan directory that root has configured, you will be asked if
11659 you want to create your own config. Answering "yes" will bring you into
11660 CPAN's configuration stage, using the system config for all defaults except
11661 things that have to do with CPAN's work directory, saving your choices to
11662 your MyConfig.pm file.
11663
11664 You can also manually initiate this process with the following command:
11665
11666     % perl -MCPAN -e 'mkmyconfig'
11667
11668 or by running
11669
11670     mkmyconfig
11671
11672 from the CPAN shell.
11673
11674 You will most probably also want to configure something like this:
11675
11676   o conf makepl_arg "LIB=~/myperl/lib \
11677                     INSTALLMAN1DIR=~/myperl/man/man1 \
11678                     INSTALLMAN3DIR=~/myperl/man/man3 \
11679                     INSTALLSCRIPT=~/myperl/bin \
11680                     INSTALLBIN=~/myperl/bin"
11681
11682 and then (oh joy) the equivalent command for Module::Build.
11683
11684 You can make this setting permanent like all C<o conf> settings with
11685 C<o conf commit> or by setting C<auto_commit> beforehand.
11686
11687 You will have to add ~/myperl/man to the MANPATH environment variable
11688 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11689 including
11690
11691   use lib "$ENV{HOME}/myperl/lib";
11692
11693 or setting the PERL5LIB environment variable.
11694
11695 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11696 that for Windows we use the File::HomeDir module that provides an
11697 equivalent to the concept of the home directory on Unix.
11698
11699 Another thing you should bear in mind is that the UNINST parameter can
11700 be dnagerous when you are installing into a private area because you
11701 might accidentally remove modules that other people depend on that are
11702 not using the private area.
11703
11704 =item 6)
11705
11706 How to get a package, unwrap it, and make a change before building it?
11707
11708 Have a look at the C<look> (!) command.
11709
11710 =item 7)
11711
11712 I installed a Bundle and had a couple of fails. When I
11713 retried, everything resolved nicely. Can this be fixed to work
11714 on first try?
11715
11716 The reason for this is that CPAN does not know the dependencies of all
11717 modules when it starts out. To decide about the additional items to
11718 install, it just uses data found in the META.yml file or the generated
11719 Makefile. An undetected missing piece breaks the process. But it may
11720 well be that your Bundle installs some prerequisite later than some
11721 depending item and thus your second try is able to resolve everything.
11722 Please note, CPAN.pm does not know the dependency tree in advance and
11723 cannot sort the queue of things to install in a topologically correct
11724 order. It resolves perfectly well IF all modules declare the
11725 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11726 the C<requires> stanza of Module::Build. For bundles which fail and
11727 you need to install often, it is recommended to sort the Bundle
11728 definition file manually.
11729
11730 =item 8)
11731
11732 In our intranet we have many modules for internal use. How
11733 can I integrate these modules with CPAN.pm but without uploading
11734 the modules to CPAN?
11735
11736 Have a look at the CPAN::Site module.
11737
11738 =item 9)
11739
11740 When I run CPAN's shell, I get an error message about things in my
11741 /etc/inputrc (or ~/.inputrc) file.
11742
11743 These are readline issues and can only be fixed by studying readline
11744 configuration on your architecture and adjusting the referenced file
11745 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11746 and edit them. Quite often harmless changes like uppercasing or
11747 lowercasing some arguments solves the problem.
11748
11749 =item 10)
11750
11751 Some authors have strange characters in their names.
11752
11753 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11754 expecting ISO-8859-1 charset, a converter can be activated by setting
11755 term_is_latin to a true value in your config file. One way of doing so
11756 would be
11757
11758     cpan> o conf term_is_latin 1
11759
11760 If other charset support is needed, please file a bugreport against
11761 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11762 the support or maybe UTF-8 terminals become widely available.
11763
11764 =item 11)
11765
11766 When an install fails for some reason and then I correct the error
11767 condition and retry, CPAN.pm refuses to install the module, saying
11768 C<Already tried without success>.
11769
11770 Use the force pragma like so
11771
11772   force install Foo::Bar
11773
11774 Or you can use
11775
11776   look Foo::Bar
11777
11778 and then 'make install' directly in the subshell.
11779
11780 =item 12)
11781
11782 How do I install a "DEVELOPER RELEASE" of a module?
11783
11784 By default, CPAN will install the latest non-developer release of a
11785 module. If you want to install a dev release, you have to specify the
11786 partial path starting with the author id to the tarball you wish to
11787 install, like so:
11788
11789     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11790
11791 Note that you can use the C<ls> command to get this path listed.
11792
11793 =item 13)
11794
11795 How do I install a module and all its dependencies from the commandline,
11796 without being prompted for anything, despite my CPAN configuration
11797 (or lack thereof)?
11798
11799 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11800 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11801 asked any questions at all (assuming the modules you are installing are
11802 nice about obeying that variable as well):
11803
11804     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11805
11806 =item 14)
11807
11808 How do I create a Module::Build based Build.PL derived from an
11809 ExtUtils::MakeMaker focused Makefile.PL?
11810
11811 http://search.cpan.org/search?query=Module::Build::Convert
11812
11813 http://www.refcnt.org/papers/module-build-convert
11814
11815 =item 15)
11816
11817 What's the best CPAN site for me?
11818
11819 The urllist config parameter is yours. You can add and remove sites at
11820 will. You should find out which sites have the best uptodateness,
11821 bandwidth, reliability, etc. and are topologically close to you. Some
11822 people prefer fast downloads, others uptodateness, others reliability.
11823 You decide which to try in which order.
11824
11825 Henk P. Penning maintains a site that collects data about CPAN sites:
11826
11827   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11828
11829 =back
11830
11831 =head1 COMPATIBILITY
11832
11833 =head2 OLD PERL VERSIONS
11834
11835 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11836 newer versions. It is getting more and more difficult to get the
11837 minimal prerequisites working on older perls. It is close to
11838 impossible to get the whole Bundle::CPAN working there. If you're in
11839 the position to have only these old versions, be advised that CPAN is
11840 designed to work fine without the Bundle::CPAN installed.
11841
11842 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11843 compatible with ancient perls and that File::Temp is listed as a
11844 prerequisite but CPAN has reasonable workarounds if it is missing.
11845
11846 =head2 CPANPLUS
11847
11848 This module and its competitor, the CPANPLUS module, are both much
11849 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11850 more modular but it was never tried to make it compatible with CPAN.pm.
11851
11852 =head1 SECURITY ADVICE
11853
11854 This software enables you to upgrade software on your computer and so
11855 is inherently dangerous because the newly installed software may
11856 contain bugs and may alter the way your computer works or even make it
11857 unusable. Please consider backing up your data before every upgrade.
11858
11859 =head1 BUGS
11860
11861 Please report bugs via http://rt.cpan.org/
11862
11863 Before submitting a bug, please make sure that the traditional method
11864 of building a Perl module package from a shell by following the
11865 installation instructions of that package still works in your
11866 environment.
11867
11868 =head1 AUTHOR
11869
11870 Andreas Koenig C<< <andk@cpan.org> >>
11871
11872 =head1 LICENSE
11873
11874 This program is free software; you can redistribute it and/or
11875 modify it under the same terms as Perl itself.
11876
11877 See L<http://www.perl.com/perl/misc/Artistic.html>
11878
11879 =head1 TRANSLATIONS
11880
11881 Kawai,Takanori provides a Japanese translation of this manpage at
11882 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11883
11884 =head1 SEE ALSO
11885
11886 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11887
11888 =cut
11889
11890