lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.9102';
   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 substr($self->id,-1,1) eq ".";
5499 }
5500
5501 # add the A/AN/ stuff
5502 #-> CPAN::Distribution::normalize
5503 sub normalize {
5504     my($self,$s) = @_;
5505     $s = $self->id unless defined $s;
5506     if (substr($s,-1,1) eq ".") {
5507         # using a global because we are sometimes called as static method
5508         if (!$CPAN::META->{LOCK}
5509             && !$CPAN::Have_warned->{"$s is unlocked"}++
5510            ) {
5511             $CPAN::Frontend->mywarn("You are visiting the local directory
5512   '$s'
5513   without lock, take care that concurrent processes do not do likewise.\n");
5514             $CPAN::Frontend->mysleep(1);
5515         }
5516         if ($s eq ".") {
5517             $s = "$CPAN::iCwd/.";
5518         } elsif (File::Spec->file_name_is_absolute($s)) {
5519         } elsif (File::Spec->can("rel2abs")) {
5520             $s = File::Spec->rel2abs($s);
5521         } else {
5522             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5523         }
5524         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5525         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5526             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5527                 $_->{build_dir} = $s;
5528                 $_->{archived} = "local_directory";
5529                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5530             }
5531         }
5532     } elsif (
5533         $s =~ tr|/|| == 1
5534         or
5535         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5536        ) {
5537         return $s if $s =~ m:^N/A|^Contact Author: ;
5538         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5539             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5540         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5541     }
5542     $s;
5543 }
5544
5545 #-> sub CPAN::Distribution::author ;
5546 sub author {
5547     my($self) = @_;
5548     my($authorid);
5549     if (substr($self->id,-1,1) eq ".") {
5550         $authorid = "LOCAL";
5551     } else {
5552         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5553     }
5554     CPAN::Shell->expand("Author",$authorid);
5555 }
5556
5557 # tries to get the yaml from CPAN instead of the distro itself:
5558 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5559 sub fast_yaml {
5560     my($self) = @_;
5561     my $meta = $self->pretty_id;
5562     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5563     my(@ls) = CPAN::Shell->globls($meta);
5564     my $norm = $self->normalize($meta);
5565
5566     my($local_file);
5567     my($local_wanted) =
5568         File::Spec->catfile(
5569                             $CPAN::Config->{keep_source_where},
5570                             "authors",
5571                             "id",
5572                             split(/\//,$norm)
5573                            );
5574     $self->debug("Doing localize") if $CPAN::DEBUG;
5575     unless ($local_file =
5576             CPAN::FTP->localize("authors/id/$norm",
5577                                 $local_wanted)) {
5578         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5579     }
5580     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5581 }
5582
5583 #-> sub CPAN::Distribution::cpan_userid
5584 sub cpan_userid {
5585     my $self = shift;
5586     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5587         return $1;
5588     }
5589     return $self->SUPER::cpan_userid;
5590 }
5591
5592 #-> sub CPAN::Distribution::pretty_id
5593 sub pretty_id {
5594     my $self = shift;
5595     my $id = $self->id;
5596     return $id unless $id =~ m|^./../|;
5597     substr($id,5);
5598 }
5599
5600 # mark as dirty/clean for the sake of recursion detection. $color=1
5601 # means "in use", $color=0 means "not in use anymore". $color=2 means
5602 # we have determined prereqs now and thus insist on passing this
5603 # through (at least) once again.
5604
5605 #-> sub CPAN::Distribution::color_cmd_tmps ;
5606 sub color_cmd_tmps {
5607     my($self) = shift;
5608     my($depth) = shift || 0;
5609     my($color) = shift || 0;
5610     my($ancestors) = shift || [];
5611     # a distribution needs to recurse into its prereq_pms
5612
5613     return if exists $self->{incommandcolor}
5614         && $color==1
5615         && $self->{incommandcolor}==$color;
5616     if ($depth>=$CPAN::MAX_RECURSION){
5617         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5618     }
5619     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5620     my $prereq_pm = $self->prereq_pm;
5621     if (defined $prereq_pm) {
5622       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5623                            keys %{$prereq_pm->{build_requires}||{}}) {
5624             next PREREQ if $pre eq "perl";
5625             my $premo;
5626             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5627                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5628                 $CPAN::Frontend->mysleep(2);
5629                 next PREREQ;
5630             }
5631             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5632         }
5633     }
5634     if ($color==0) {
5635         delete $self->{sponsored_mods};
5636
5637         # as we are at the end of a command, we'll give up this
5638         # reminder of a broken test. Other commands may test this guy
5639         # again. Maybe 'badtestcnt' should be renamed to
5640         # 'make_test_failed_within_command'?
5641         delete $self->{badtestcnt};
5642     }
5643     $self->{incommandcolor} = $color;
5644 }
5645
5646 #-> sub CPAN::Distribution::as_string ;
5647 sub as_string {
5648   my $self = shift;
5649   $self->containsmods;
5650   $self->upload_date;
5651   $self->SUPER::as_string(@_);
5652 }
5653
5654 #-> sub CPAN::Distribution::containsmods ;
5655 sub containsmods {
5656   my $self = shift;
5657   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5658   my $dist_id = $self->{ID};
5659   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5660     my $mod_file = $mod->cpan_file or next;
5661     my $mod_id = $mod->{ID} or next;
5662     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5663     # sleep 1;
5664     if ($CPAN::Signal) {
5665         delete $self->{CONTAINSMODS};
5666         return;
5667     }
5668     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5669   }
5670   keys %{$self->{CONTAINSMODS}||{}};
5671 }
5672
5673 #-> sub CPAN::Distribution::upload_date ;
5674 sub upload_date {
5675   my $self = shift;
5676   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5677   my(@local_wanted) = split(/\//,$self->id);
5678   my $filename = pop @local_wanted;
5679   push @local_wanted, "CHECKSUMS";
5680   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5681   return unless $author;
5682   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5683   return unless @dl;
5684   my($dirent) = grep { $_->[2] eq $filename } @dl;
5685   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5686   return unless $dirent->[1];
5687   return $self->{UPLOAD_DATE} = $dirent->[1];
5688 }
5689
5690 #-> sub CPAN::Distribution::uptodate ;
5691 sub uptodate {
5692     my($self) = @_;
5693     my $c;
5694     foreach $c ($self->containsmods) {
5695         my $obj = CPAN::Shell->expandany($c);
5696         unless ($obj->uptodate){
5697             my $id = $self->pretty_id;
5698             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5699             return 0;
5700         }
5701     }
5702     return 1;
5703 }
5704
5705 #-> sub CPAN::Distribution::called_for ;
5706 sub called_for {
5707     my($self,$id) = @_;
5708     $self->{CALLED_FOR} = $id if defined $id;
5709     return $self->{CALLED_FOR};
5710 }
5711
5712 #-> sub CPAN::Distribution::get ;
5713 sub get {
5714     my($self) = @_;
5715     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5716     if (my $goto = $self->prefs->{goto}) {
5717         $CPAN::Frontend->mywarn
5718             (sprintf(
5719                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5720                      $goto,
5721                      $self->{prefs_file},
5722                      $self->{prefs_file_doc},
5723                     ));
5724         return $self->goto($goto);
5725     }
5726     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5727                            ? $ENV{PERL5LIB}
5728                            : ($ENV{PERLLIB} || "");
5729
5730     $CPAN::META->set_perl5lib;
5731     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5732
5733   EXCUSE: {
5734         my @e;
5735         my $goodbye_message;
5736         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5737         if ($self->prefs->{disabled}) {
5738             my $why = sprintf(
5739                               "Disabled via prefs file '%s' doc %d",
5740                               $self->{prefs_file},
5741                               $self->{prefs_file_doc},
5742                              );
5743             push @e, $why;
5744             $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
5745             $goodbye_message = "[disabled] -- NA $why";
5746             # note: not intended to be persistent but at least visible
5747             # during this session
5748         } else {
5749             if (exists $self->{build_dir} && -d $self->{build_dir}
5750                 && ($self->{modulebuild}||$self->{writemakefile})
5751                ) {
5752                 # this deserves print, not warn:
5753                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5754                                          "$self->{build_dir}\n"
5755                                         );
5756                 return 1;
5757             }
5758
5759             # although we talk about 'force' we shall not test on
5760             # force directly. New model of force tries to refrain from
5761             # direct checking of force.
5762             exists $self->{unwrapped} and (
5763                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5764                                            $self->{unwrapped}->failed :
5765                                            $self->{unwrapped} =~ /^NO/
5766                                           )
5767                 and push @e, "Unwrapping had some problem, won't try again without force";
5768         }
5769         if (@e) {
5770             $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e);
5771             if ($goodbye_message) {
5772                  $self->goodbye($goodbye_message);
5773             }
5774             return;
5775         }
5776     }
5777     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5778
5779     $self->get_file_onto_local_disk;
5780     return if $CPAN::Signal;
5781     $self->check_integrity;
5782     return if $CPAN::Signal;
5783     my($packagedir,$local_file) = $self->run_preps_on_packagedir;
5784     $packagedir ||= $self->{build_dir};
5785
5786     if ($CPAN::Signal){
5787         $self->safe_chdir($sub_wd);
5788         return;
5789     }
5790     return $self->run_MM_or_MB($local_file,$packagedir);
5791 }
5792
5793 #-> CPAN::Distribution::get_file_onto_local_disk
5794 sub get_file_onto_local_disk {
5795     my($self) = @_;
5796
5797     return if $self->is_dot_dist;
5798     my($local_file);
5799     my($local_wanted) =
5800         File::Spec->catfile(
5801                             $CPAN::Config->{keep_source_where},
5802                             "authors",
5803                             "id",
5804                             split(/\//,$self->id)
5805                            );
5806
5807     $self->debug("Doing localize") if $CPAN::DEBUG;
5808     unless ($local_file =
5809             CPAN::FTP->localize("authors/id/$self->{ID}",
5810                                 $local_wanted)) {
5811         my $note = "";
5812         if ($CPAN::Index::DATE_OF_02) {
5813             $note = "Note: Current database in memory was generated ".
5814                 "on $CPAN::Index::DATE_OF_02\n";
5815         }
5816         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5817     }
5818
5819     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5820     $self->{localfile} = $local_file;
5821 }
5822
5823
5824 #-> CPAN::Distribution::check_integrity
5825 sub check_integrity {
5826     my($self) = @_;
5827
5828     return if $self->is_dot_dist;
5829     if ($CPAN::META->has_inst("Digest::SHA")) {
5830         $self->debug("Digest::SHA is installed, verifying");
5831         $self->verifyCHECKSUM;
5832     } else {
5833         $self->debug("Digest::SHA is NOT installed");
5834     }
5835 }
5836
5837 #-> CPAN::Distribution::run_preps_on_packagedir
5838 sub run_preps_on_packagedir {
5839     my($self) = @_;
5840     return if $self->is_dot_dist;
5841
5842     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5843     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5844     $self->safe_chdir($builddir);
5845     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5846     File::Path::rmtree("tmp-$$");
5847     unless (mkdir "tmp-$$", 0755) {
5848         $CPAN::Frontend->unrecoverable_error(<<EOF);
5849 Couldn't mkdir '$builddir/tmp-$$': $!
5850
5851 Cannot continue: Please find the reason why I cannot make the
5852 directory
5853 $builddir/tmp-$$
5854 and fix the problem, then retry.
5855
5856 EOF
5857     }
5858     if ($CPAN::Signal){
5859         return;
5860     }
5861     $self->safe_chdir("tmp-$$");
5862
5863     #
5864     # Unpack the goods
5865     #
5866     my $local_file = $self->{localfile};
5867     my $ct = eval{CPAN::Tarzip->new($local_file)};
5868     unless ($ct) {
5869         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5870         delete $self->{build_dir};
5871         return;
5872     }
5873     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5874         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5875         $self->untar_me($ct);
5876     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5877         $self->unzip_me($ct);
5878     } else {
5879         $self->{was_uncompressed}++ unless $ct->gtest();
5880         $local_file = $self->handle_singlefile($local_file);
5881     }
5882
5883     # we are still in the tmp directory!
5884     # Let's check if the package has its own directory.
5885     my $dh = DirHandle->new(File::Spec->curdir)
5886         or Carp::croak("Couldn't opendir .: $!");
5887     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5888     $dh->close;
5889     my ($packagedir);
5890     # XXX here we want in each branch File::Temp to protect all build_dir directories
5891     if (CPAN->has_inst("File::Temp")) {
5892         my $tdir_base;
5893         my $from_dir;
5894         my @dirents;
5895         if (@readdir == 1 && -d $readdir[0]) {
5896             $tdir_base = $readdir[0];
5897             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5898             my $dh2 = DirHandle->new($from_dir)
5899                 or Carp::croak("Couldn't opendir $from_dir: $!");
5900             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5901         } else {
5902             my $userid = $self->cpan_userid;
5903             CPAN->debug("userid[$userid]");
5904             if (!$userid or $userid eq "N/A") {
5905                 $userid = "anon";
5906             }
5907             $tdir_base = $userid;
5908             $from_dir = File::Spec->curdir;
5909             @dirents = @readdir;
5910         }
5911         $packagedir = File::Temp::tempdir(
5912                                           "$tdir_base-XXXXXX",
5913                                           DIR => $builddir,
5914                                           CLEANUP => 0,
5915                                          );
5916         my $f;
5917         for $f (@dirents) { # is already without "." and ".."
5918             my $from = File::Spec->catdir($from_dir,$f);
5919             my $to = File::Spec->catdir($packagedir,$f);
5920             unless (File::Copy::move($from,$to)) {
5921                 my $err = $!;
5922                 $from = File::Spec->rel2abs($from);
5923                 Carp::confess("Couldn't move $from to $to: $err");
5924             }
5925         }
5926     } else { # older code below, still better than nothing when there is no File::Temp
5927         my($distdir);
5928         if (@readdir == 1 && -d $readdir[0]) {
5929             $distdir = $readdir[0];
5930             $packagedir = File::Spec->catdir($builddir,$distdir);
5931             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5932                 if $CPAN::DEBUG;
5933             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5934                                                         "$packagedir\n");
5935             File::Path::rmtree($packagedir);
5936             unless (File::Copy::move($distdir,$packagedir)) {
5937                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5938 Couldn't move '$distdir' to '$packagedir': $!
5939
5940 Cannot continue: Please find the reason why I cannot move
5941 $builddir/tmp-$$/$distdir
5942 to
5943 $packagedir
5944 and fix the problem, then retry
5945
5946 EOF
5947             }
5948             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5949                                  $distdir,
5950                                  $packagedir,
5951                                  -e $packagedir,
5952                                  -d $packagedir,
5953                                 )) if $CPAN::DEBUG;
5954         } else {
5955             my $userid = $self->cpan_userid;
5956             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5957             if (!$userid or $userid eq "N/A") {
5958                 $userid = "anon";
5959             }
5960             my $pragmatic_dir = $userid . '000';
5961             $pragmatic_dir =~ s/\W_//g;
5962             $pragmatic_dir++ while -d "../$pragmatic_dir";
5963             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5964             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5965             File::Path::mkpath($packagedir);
5966             my($f);
5967             for $f (@readdir) { # is already without "." and ".."
5968                 my $to = File::Spec->catdir($packagedir,$f);
5969                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5970             }
5971         }
5972     }
5973     $self->{build_dir} = $packagedir;
5974     $self->safe_chdir($builddir);
5975     File::Path::rmtree("tmp-$$");
5976
5977     $self->safe_chdir($packagedir);
5978     $self->_signature_business();
5979     $self->safe_chdir($builddir);
5980
5981     return($packagedir,$local_file);
5982 }
5983
5984 #-> sub CPAN::Distribution::run_MM_or_MB
5985 sub run_MM_or_MB {
5986     my($self,$local_file,$packagedir) = @_;
5987     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5988     my($mpl_exists) = -f $mpl;
5989     unless ($mpl_exists) {
5990         # NFS has been reported to have racing problems after the
5991         # renaming of a directory in some environments.
5992         # This trick helps.
5993         $CPAN::Frontend->mysleep(1);
5994         my $mpldh = DirHandle->new($packagedir)
5995             or Carp::croak("Couldn't opendir $packagedir: $!");
5996         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5997         $mpldh->close;
5998     }
5999     my $prefer_installer = "eumm"; # eumm|mb
6000     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
6001         if ($mpl_exists) { # they *can* choose
6002             if ($CPAN::META->has_inst("Module::Build")) {
6003                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
6004                                                                      q{prefer_installer});
6005             }
6006         } else {
6007             $prefer_installer = "mb";
6008         }
6009     }
6010     return unless $self->patch;
6011     if (lc($prefer_installer) eq "mb") {
6012         $self->{modulebuild} = 1;
6013     } elsif ($self->{archived} eq "patch") {
6014         # not an edge case, nothing to install for sure
6015         my $why = "A patch file cannot be installed";
6016         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
6017         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
6018     } elsif (! $mpl_exists) {
6019         $self->_edge_cases($mpl,$packagedir,$local_file);
6020     }
6021     if ($self->{build_dir}
6022         &&
6023         $CPAN::Config->{build_dir_reuse}
6024        ) {
6025         $self->store_persistent_state;
6026     }
6027     return $self;
6028 }
6029
6030 #-> CPAN::Distribution::store_persistent_state
6031 sub store_persistent_state {
6032     my($self) = @_;
6033     my $dir = $self->{build_dir};
6034     unless (File::Spec->canonpath(File::Basename::dirname($dir))
6035             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
6036         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
6037                                 "will not store persistent state\n");
6038         return;
6039     }
6040     my $file = sprintf "%s.yml", $dir;
6041     my $yaml_module = CPAN::_yaml_module;
6042     if ($CPAN::META->has_inst($yaml_module)) {
6043         CPAN->_yaml_dumpfile(
6044                              $file,
6045                              {
6046                               time => time,
6047                               perl => CPAN::_perl_fingerprint,
6048                               distribution => $self,
6049                              }
6050                             );
6051     } else {
6052         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6053                                 "will not store persistent state\n");
6054     }
6055 }
6056
6057 #-> CPAN::Distribution::patch
6058 sub try_download {
6059     my($self,$patch) = @_;
6060     my $norm = $self->normalize($patch);
6061     my($local_wanted) =
6062         File::Spec->catfile(
6063                             $CPAN::Config->{keep_source_where},
6064                             "authors",
6065                             "id",
6066                             split(/\//,$norm),
6067                             );
6068     $self->debug("Doing localize") if $CPAN::DEBUG;
6069     return CPAN::FTP->localize("authors/id/$norm",
6070                                $local_wanted);
6071 }
6072
6073 {
6074     my $stdpatchargs = "";
6075     #-> CPAN::Distribution::patch
6076     sub patch {
6077         my($self) = @_;
6078         $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6079         my $patches = $self->prefs->{patches};
6080         $patches ||= "";
6081         $self->debug("patches[$patches]") if $CPAN::DEBUG;
6082         if ($patches) {
6083             return unless @$patches;
6084             $self->safe_chdir($self->{build_dir});
6085             CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6086             my $patchbin = $CPAN::Config->{patch};
6087             unless ($patchbin && length $patchbin) {
6088                 $CPAN::Frontend->mydie("No external patch command configured\n\n".
6089                                        "Please run 'o conf init /patch/'\n\n");
6090             }
6091             unless (MM->maybe_command($patchbin)) {
6092                 $CPAN::Frontend->mydie("No external patch command available\n\n".
6093                                        "Please run 'o conf init /patch/'\n\n");
6094             }
6095             $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6096             local $ENV{PATCH_GET} = 0; # formerly known as -g0
6097             unless ($stdpatchargs) {
6098                 my $system = "$patchbin --version |";
6099                 local *FH;
6100                 open FH, $system or die "Could not fork '$system': $!";
6101                 local $/ = "\n";
6102                 my $pversion;
6103               PARSEVERSION: while (<FH>) {
6104                     if (/^patch\s+([\d\.]+)/) {
6105                         $pversion = $1;
6106                         last PARSEVERSION;
6107                     }
6108                 }
6109                 if ($pversion) {
6110                     $stdpatchargs = "-N --fuzz=3";
6111                 } else {
6112                     $stdpatchargs = "-N";
6113                 }
6114             }
6115             my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6116             $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6117             for my $patch (@$patches) {
6118                 unless (-f $patch) {
6119                     if (my $trydl = $self->try_download($patch)) {
6120                         $patch = $trydl;
6121                     } else {
6122                         my $fail = "Could not find patch '$patch'";
6123                         $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6124                         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6125                         delete $self->{build_dir};
6126                         return;
6127                     }
6128                 }
6129                 $CPAN::Frontend->myprint("  $patch\n");
6130                 my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6131
6132                 my $pcommand;
6133                 my $ppp = $self->_patch_p_parameter($readfh);
6134                 if ($ppp eq "applypatch") {
6135                     $pcommand = "$CPAN::Config->{applypatch} -verbose";
6136                 } else {
6137                     my $thispatchargs = join " ", $stdpatchargs, $ppp;
6138                     $pcommand = "$patchbin $thispatchargs";
6139                 }
6140
6141                 $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6142                 my $writefh = FileHandle->new;
6143                 $CPAN::Frontend->myprint("  $pcommand\n");
6144                 unless (open $writefh, "|$pcommand") {
6145                     my $fail = "Could not fork '$pcommand'";
6146                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6147                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6148                     delete $self->{build_dir};
6149                     return;
6150                 }
6151                 while (my $x = $readfh->READLINE) {
6152                     print $writefh $x;
6153                 }
6154                 unless (close $writefh) {
6155                     my $fail = "Could not apply patch '$patch'";
6156                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6157                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6158                     delete $self->{build_dir};
6159                     return;
6160                 }
6161             }
6162             $self->{patched}++;
6163         }
6164         return 1;
6165     }
6166 }
6167
6168 sub _patch_p_parameter {
6169     my($self,$fh) = @_;
6170     my $cnt_files   = 0;
6171     my $cnt_p0files = 0;
6172     local($_);
6173     while ($_ = $fh->READLINE) {
6174         if (
6175             $CPAN::Config->{applypatch}
6176             &&
6177             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6178            ) {
6179             return "applypatch"
6180         }
6181         next unless /^[\*\+]{3}\s(\S+)/;
6182         my $file = $1;
6183         $cnt_files++;
6184         $cnt_p0files++ if -f $file;
6185         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6186             if $CPAN::DEBUG;
6187     }
6188     return "-p1" unless $cnt_files;
6189     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6190 }
6191
6192 #-> sub CPAN::Distribution::_edge_cases
6193 # with "configure" or "Makefile" or single file scripts
6194 sub _edge_cases {
6195     my($self,$mpl,$packagedir,$local_file) = @_;
6196     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6197                          $mpl,
6198                          CPAN::anycwd(),
6199                         )) if $CPAN::DEBUG;
6200     my($configure) = File::Spec->catfile($packagedir,"Configure");
6201     if (-f $configure) {
6202         # do we have anything to do?
6203         $self->{configure} = $configure;
6204     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6205         $CPAN::Frontend->mywarn(qq{
6206 Package comes with a Makefile and without a Makefile.PL.
6207 We\'ll try to build it with that Makefile then.
6208 });
6209         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6210         $CPAN::Frontend->mysleep(2);
6211     } else {
6212         my $cf = $self->called_for || "unknown";
6213         if ($cf =~ m|/|) {
6214             $cf =~ s|.*/||;
6215             $cf =~ s|\W.*||;
6216         }
6217         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6218         $cf = "unknown" unless length($cf);
6219         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6220   (The test -f "$mpl" returned false.)
6221   Writing one on our own (setting NAME to $cf)\a\n});
6222         $self->{had_no_makefile_pl}++;
6223         $CPAN::Frontend->mysleep(3);
6224
6225         # Writing our own Makefile.PL
6226
6227         my $script = "";
6228         if ($self->{archived} eq "maybe_pl") {
6229             my $fh = FileHandle->new;
6230             my $script_file = File::Spec->catfile($packagedir,$local_file);
6231             $fh->open($script_file)
6232                 or Carp::croak("Could not open script '$script_file': $!");
6233             local $/ = "\n";
6234             # name parsen und prereq
6235             my($state) = "poddir";
6236             my($name, $prereq) = ("", "");
6237             while (<$fh>) {
6238                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6239                     if ($1 eq 'NAME') {
6240                         $state = "name";
6241                     } elsif ($1 eq 'PREREQUISITES') {
6242                         $state = "prereq";
6243                     }
6244                 } elsif ($state =~ m{^(name|prereq)$}) {
6245                     if (/^=/) {
6246                         $state = "poddir";
6247                     } elsif (/^\s*$/) {
6248                         # nop
6249                     } elsif ($state eq "name") {
6250                         if ($name eq "") {
6251                             ($name) = /^(\S+)/;
6252                             $state = "poddir";
6253                         }
6254                     } elsif ($state eq "prereq") {
6255                         $prereq .= $_;
6256                     }
6257                 } elsif (/^=cut\b/) {
6258                     last;
6259                 }
6260             }
6261             $fh->close;
6262
6263             for ($name) {
6264                 s{.*<}{};       # strip X<...>
6265                 s{>.*}{};
6266             }
6267             chomp $prereq;
6268             $prereq = join " ", split /\s+/, $prereq;
6269             my($PREREQ_PM) = join("\n", map {
6270                 s{.*<}{};       # strip X<...>
6271                 s{>.*}{};
6272                 if (/[\s\'\"]/) { # prose?
6273                 } else {
6274                     s/[^\w:]$//; # period?
6275                     " "x28 . "'$_' => 0,";
6276                 }
6277             } split /\s*,\s*/, $prereq);
6278
6279             $script = "
6280               EXE_FILES => ['$name'],
6281               PREREQ_PM => {
6282 $PREREQ_PM
6283                            },
6284 ";
6285             if ($name) {
6286                 my $to_file = File::Spec->catfile($packagedir, $name);
6287                 rename $script_file, $to_file
6288                     or die "Can't rename $script_file to $to_file: $!";
6289             }
6290         }
6291
6292         my $fh = FileHandle->new;
6293         $fh->open(">$mpl")
6294             or Carp::croak("Could not open >$mpl: $!");
6295         $fh->print(
6296                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6297 # because there was no Makefile.PL supplied.
6298 # Autogenerated on: }.scalar localtime().qq{
6299
6300 use ExtUtils::MakeMaker;
6301 WriteMakefile(
6302               NAME => q[$cf],$script
6303              );
6304 });
6305         $fh->close;
6306     }
6307 }
6308
6309 #-> CPAN::Distribution::_signature_business
6310 sub _signature_business {
6311     my($self) = @_;
6312     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6313                                                       q{check_sigs});
6314     if ($check_sigs) {
6315         if ($CPAN::META->has_inst("Module::Signature")) {
6316             if (-f "SIGNATURE") {
6317                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6318                 my $rv = Module::Signature::verify();
6319                 if ($rv != Module::Signature::SIGNATURE_OK() and
6320                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6321                     $CPAN::Frontend->mywarn(
6322                                             qq{\nSignature invalid for }.
6323                                             qq{distribution file. }.
6324                                             qq{Please investigate.\n\n}
6325                                            );
6326
6327                     my $wrap =
6328                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6329                                 qq{while checking its signature, so it could        }.
6330                                 qq{be invalid. Maybe you have configured            }.
6331                                 qq{your 'urllist' with a bad URL. Please check this }.
6332                                 qq{array with 'o conf urllist' and retry. Or        }.
6333                                 qq{examine the distribution in a subshell. Try
6334   look %s
6335 and run
6336   cpansign -v
6337 },
6338                                 $self->{localfile},
6339                                 $self->pretty_id,
6340                                );
6341                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6342                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6343                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6344                 } else {
6345                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6346                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6347                 }
6348             } else {
6349                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6350             }
6351         } else {
6352             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6353         }
6354     }
6355 }
6356
6357 #-> CPAN::Distribution::untar_me ;
6358 sub untar_me {
6359     my($self,$ct) = @_;
6360     $self->{archived} = "tar";
6361     if ($ct->untar()) {
6362         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6363     } else {
6364         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6365     }
6366 }
6367
6368 # CPAN::Distribution::unzip_me ;
6369 sub unzip_me {
6370     my($self,$ct) = @_;
6371     $self->{archived} = "zip";
6372     if ($ct->unzip()) {
6373         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6374     } else {
6375         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6376     }
6377     return;
6378 }
6379
6380 sub handle_singlefile {
6381     my($self,$local_file) = @_;
6382
6383     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6384         $self->{archived} = "pm";
6385     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6386         $self->{archived} = "patch";
6387     } else {
6388         $self->{archived} = "maybe_pl";
6389     }
6390
6391     my $to = File::Basename::basename($local_file);
6392     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6393         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6394             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6395         } else {
6396             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6397         }
6398     } else {
6399         if (File::Copy::cp($local_file,".")) {
6400             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6401         } else {
6402             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6403         }
6404     }
6405     return $to;
6406 }
6407
6408 #-> sub CPAN::Distribution::new ;
6409 sub new {
6410     my($class,%att) = @_;
6411
6412     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6413
6414     my $this = { %att };
6415     return bless $this, $class;
6416 }
6417
6418 #-> sub CPAN::Distribution::look ;
6419 sub look {
6420     my($self) = @_;
6421
6422     if ($^O eq 'MacOS') {
6423       $self->Mac::BuildTools::look;
6424       return;
6425     }
6426
6427     if (  $CPAN::Config->{'shell'} ) {
6428         $CPAN::Frontend->myprint(qq{
6429 Trying to open a subshell in the build directory...
6430 });
6431     } else {
6432         $CPAN::Frontend->myprint(qq{
6433 Your configuration does not define a value for subshells.
6434 Please define it with "o conf shell <your shell>"
6435 });
6436         return;
6437     }
6438     my $dist = $self->id;
6439     my $dir;
6440     unless ($dir = $self->dir) {
6441         $self->get;
6442     }
6443     unless ($dir ||= $self->dir) {
6444         $CPAN::Frontend->mywarn(qq{
6445 Could not determine which directory to use for looking at $dist.
6446 });
6447         return;
6448     }
6449     my $pwd  = CPAN::anycwd();
6450     $self->safe_chdir($dir);
6451     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6452     {
6453         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6454         $ENV{CPAN_SHELL_LEVEL} += 1;
6455         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6456         unless (system($shell) == 0) {
6457             my $code = $? >> 8;
6458             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6459         }
6460     }
6461     $self->safe_chdir($pwd);
6462 }
6463
6464 # CPAN::Distribution::cvs_import ;
6465 sub cvs_import {
6466     my($self) = @_;
6467     $self->get;
6468     my $dir = $self->dir;
6469
6470     my $package = $self->called_for;
6471     my $module = $CPAN::META->instance('CPAN::Module', $package);
6472     my $version = $module->cpan_version;
6473
6474     my $userid = $self->cpan_userid;
6475
6476     my $cvs_dir = (split /\//, $dir)[-1];
6477     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6478     my $cvs_root =
6479       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6480     my $cvs_site_perl =
6481       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6482     if ($cvs_site_perl) {
6483         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6484     }
6485     my $cvs_log = qq{"imported $package $version sources"};
6486     $version =~ s/\./_/g;
6487     # XXX cvs: undocumented and unclear how it was meant to work
6488     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6489                "$cvs_dir", $userid, "v$version");
6490
6491     my $pwd  = CPAN::anycwd();
6492     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6493
6494     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6495
6496     $CPAN::Frontend->myprint(qq{@cmd\n});
6497     system(@cmd) == 0 or
6498     # XXX cvs
6499         $CPAN::Frontend->mydie("cvs import failed");
6500     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6501 }
6502
6503 #-> sub CPAN::Distribution::readme ;
6504 sub readme {
6505     my($self) = @_;
6506     my($dist) = $self->id;
6507     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6508     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6509     my($local_file);
6510     my($local_wanted) =
6511          File::Spec->catfile(
6512                              $CPAN::Config->{keep_source_where},
6513                              "authors",
6514                              "id",
6515                              split(/\//,"$sans.readme"),
6516                             );
6517     $self->debug("Doing localize") if $CPAN::DEBUG;
6518     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6519                                       $local_wanted)
6520         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6521
6522     if ($^O eq 'MacOS') {
6523         Mac::BuildTools::launch_file($local_file);
6524         return;
6525     }
6526
6527     my $fh_pager = FileHandle->new;
6528     local($SIG{PIPE}) = "IGNORE";
6529     my $pager = $CPAN::Config->{'pager'} || "cat";
6530     $fh_pager->open("|$pager")
6531         or die "Could not open pager $pager\: $!";
6532     my $fh_readme = FileHandle->new;
6533     $fh_readme->open($local_file)
6534         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6535     $CPAN::Frontend->myprint(qq{
6536 Displaying file
6537   $local_file
6538 with pager "$pager"
6539 });
6540     $fh_pager->print(<$fh_readme>);
6541     $fh_pager->close;
6542 }
6543
6544 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6545 sub verifyCHECKSUM {
6546     my($self) = @_;
6547   EXCUSE: {
6548         my @e;
6549         $self->{CHECKSUM_STATUS} ||= "";
6550         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6551         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6552     }
6553     my($lc_want,$lc_file,@local,$basename);
6554     @local = split(/\//,$self->id);
6555     pop @local;
6556     push @local, "CHECKSUMS";
6557     $lc_want =
6558         File::Spec->catfile($CPAN::Config->{keep_source_where},
6559                             "authors", "id", @local);
6560     local($") = "/";
6561     if (my $size = -s $lc_want) {
6562         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6563         if ($self->CHECKSUM_check_file($lc_want,1)) {
6564             return $self->{CHECKSUM_STATUS} = "OK";
6565         }
6566     }
6567     $lc_file = CPAN::FTP->localize("authors/id/@local",
6568                                    $lc_want,1);
6569     unless ($lc_file) {
6570         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6571         $local[-1] .= ".gz";
6572         $lc_file = CPAN::FTP->localize("authors/id/@local",
6573                                        "$lc_want.gz",1);
6574         if ($lc_file) {
6575             $lc_file =~ s/\.gz(?!\n)\Z//;
6576             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6577         } else {
6578             return;
6579         }
6580     }
6581     if ($self->CHECKSUM_check_file($lc_file)) {
6582         return $self->{CHECKSUM_STATUS} = "OK";
6583     }
6584 }
6585
6586 #-> sub CPAN::Distribution::SIG_check_file ;
6587 sub SIG_check_file {
6588     my($self,$chk_file) = @_;
6589     my $rv = eval { Module::Signature::_verify($chk_file) };
6590
6591     if ($rv == Module::Signature::SIGNATURE_OK()) {
6592         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6593         return $self->{SIG_STATUS} = "OK";
6594     } else {
6595         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6596                                  qq{distribution file. }.
6597                                  qq{Please investigate.\n\n}.
6598                                  $self->as_string,
6599                                 $CPAN::META->instance(
6600                                                         'CPAN::Author',
6601                                                         $self->cpan_userid
6602                                                         )->as_string);
6603
6604         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6605 is invalid. Maybe you have configured your 'urllist' with
6606 a bad URL. Please check this array with 'o conf urllist', and
6607 retry.};
6608
6609         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6610     }
6611 }
6612
6613 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6614
6615 # sloppy is 1 when we have an old checksums file that maybe is good
6616 # enough
6617
6618 sub CHECKSUM_check_file {
6619     my($self,$chk_file,$sloppy) = @_;
6620     my($cksum,$file,$basename);
6621
6622     $sloppy ||= 0;
6623     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6624     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6625                                                       q{check_sigs});
6626     if ($check_sigs) {
6627         if ($CPAN::META->has_inst("Module::Signature")) {
6628             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6629             $self->SIG_check_file($chk_file);
6630         } else {
6631             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6632         }
6633     }
6634
6635     $file = $self->{localfile};
6636     $basename = File::Basename::basename($file);
6637     my $fh = FileHandle->new;
6638     if (open $fh, $chk_file){
6639         local($/);
6640         my $eval = <$fh>;
6641         $eval =~ s/\015?\012/\n/g;
6642         close $fh;
6643         my($comp) = Safe->new();
6644         $cksum = $comp->reval($eval);
6645         if ($@) {
6646             rename $chk_file, "$chk_file.bad";
6647             Carp::confess($@) if $@;
6648         }
6649     } else {
6650         Carp::carp "Could not open $chk_file for reading";
6651     }
6652
6653     if (! ref $cksum or ref $cksum ne "HASH") {
6654         $CPAN::Frontend->mywarn(qq{
6655 Warning: checksum file '$chk_file' broken.
6656
6657 When trying to read that file I expected to get a hash reference
6658 for further processing, but got garbage instead.
6659 });
6660         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6661         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6662         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6663         return;
6664     } elsif (exists $cksum->{$basename}{sha256}) {
6665         $self->debug("Found checksum for $basename:" .
6666                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6667
6668         open($fh, $file);
6669         binmode $fh;
6670         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6671         $fh->close;
6672         $fh = CPAN::Tarzip->TIEHANDLE($file);
6673
6674         unless ($eq) {
6675           my $dg = Digest::SHA->new(256);
6676           my($data,$ref);
6677           $ref = \$data;
6678           while ($fh->READ($ref, 4096) > 0){
6679             $dg->add($data);
6680           }
6681           my $hexdigest = $dg->hexdigest;
6682           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6683         }
6684
6685         if ($eq) {
6686           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6687           return $self->{CHECKSUM_STATUS} = "OK";
6688         } else {
6689             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6690                                      qq{distribution file. }.
6691                                      qq{Please investigate.\n\n}.
6692                                      $self->as_string,
6693                                      $CPAN::META->instance(
6694                                                            'CPAN::Author',
6695                                                            $self->cpan_userid
6696                                                           )->as_string);
6697
6698             my $wrap = qq{I\'d recommend removing $file. Its
6699 checksum is incorrect. Maybe you have configured your 'urllist' with
6700 a bad URL. Please check this array with 'o conf urllist', and
6701 retry.};
6702
6703             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6704
6705             # former versions just returned here but this seems a
6706             # serious threat that deserves a die
6707
6708             # $CPAN::Frontend->myprint("\n\n");
6709             # sleep 3;
6710             # return;
6711         }
6712         # close $fh if fileno($fh);
6713     } else {
6714         return if $sloppy;
6715         unless ($self->{CHECKSUM_STATUS}) {
6716             $CPAN::Frontend->mywarn(qq{
6717 Warning: No checksum for $basename in $chk_file.
6718
6719 The cause for this may be that the file is very new and the checksum
6720 has not yet been calculated, but it may also be that something is
6721 going awry right now.
6722 });
6723             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6724             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6725         }
6726         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6727         return;
6728     }
6729 }
6730
6731 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6732 sub eq_CHECKSUM {
6733     my($self,$fh,$expect) = @_;
6734     if ($CPAN::META->has_inst("Digest::SHA")) {
6735         my $dg = Digest::SHA->new(256);
6736         my($data);
6737         while (read($fh, $data, 4096)){
6738             $dg->add($data);
6739         }
6740         my $hexdigest = $dg->hexdigest;
6741         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6742         return $hexdigest eq $expect;
6743     }
6744     return 1;
6745 }
6746
6747 #-> sub CPAN::Distribution::force ;
6748
6749 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6750 # effect by autoinspection, not by inspecting a global variable. One
6751 # of the reason why this was chosen to work that way was the treatment
6752 # of dependencies. They should not automatically inherit the force
6753 # status. But this has the downside that ^C and die() will return to
6754 # the prompt but will not be able to reset the force_update
6755 # attributes. We try to correct for it currently in the read_metadata
6756 # routine, and immediately before we check for a Signal. I hope this
6757 # works out in one of v1.57_53ff
6758
6759 # "Force get forgets previous error conditions"
6760
6761 #-> sub CPAN::Distribution::fforce ;
6762 sub fforce {
6763   my($self, $method) = @_;
6764   $self->force($method,1);
6765 }
6766
6767 #-> sub CPAN::Distribution::force ;
6768 sub force {
6769   my($self, $method,$fforce) = @_;
6770   my %phase_map = (
6771                    get => [
6772                            "unwrapped",
6773                            "build_dir",
6774                            "archived",
6775                            "localfile",
6776                            "CHECKSUM_STATUS",
6777                            "signature_verify",
6778                            "prefs",
6779                            "prefs_file",
6780                            "prefs_file_doc",
6781                           ],
6782                    make => [
6783                             "writemakefile",
6784                             "make",
6785                             "modulebuild",
6786                             "prereq_pm",
6787                             "prereq_pm_detected",
6788                            ],
6789                    test => [
6790                             "badtestcnt",
6791                             "make_test",
6792                            ],
6793                    install => [
6794                                "install",
6795                               ],
6796                    unknown => [
6797                                "reqtype",
6798                                "yaml_content",
6799                               ],
6800                   );
6801   my $methodmatch = 0;
6802   my $ldebug = 0;
6803  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6804       $methodmatch = 1 if $fforce || $phase eq $method;
6805       next unless $methodmatch;
6806     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6807           if ($phase eq "get") {
6808               if (substr($self->id,-1,1) eq "."
6809                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6810                   # cannot be undone for local distros
6811                   next ATTRIBUTE;
6812               }
6813               if ($att eq "build_dir"
6814                   && $self->{build_dir}
6815                   && $CPAN::META->{is_tested}
6816                  ) {
6817                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6818               }
6819           } elsif ($phase eq "test") {
6820               if ($att eq "make_test"
6821                   && $self->{make_test}
6822                   && $self->{make_test}{COMMANDID}
6823                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6824                  ) {
6825                   # endless loop too likely
6826                   next ATTRIBUTE;
6827               }
6828           }
6829           delete $self->{$att};
6830           if ($ldebug || $CPAN::DEBUG) {
6831               # local $CPAN::DEBUG = 16; # Distribution
6832               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6833           }
6834       }
6835   }
6836   if ($method && $method =~ /make|test|install/) {
6837     $self->{force_update} = 1; # name should probably have been force_install
6838   }
6839 }
6840
6841 #-> sub CPAN::Distribution::notest ;
6842 sub notest {
6843   my($self, $method) = @_;
6844   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
6845   $self->{"notest"}++; # name should probably have been force_install
6846 }
6847
6848 #-> sub CPAN::Distribution::unnotest ;
6849 sub unnotest {
6850   my($self) = @_;
6851   # warn "XDEBUG: deleting notest";
6852   delete $self->{notest};
6853 }
6854
6855 #-> sub CPAN::Distribution::unforce ;
6856 sub unforce {
6857   my($self) = @_;
6858   delete $self->{force_update};
6859 }
6860
6861 #-> sub CPAN::Distribution::isa_perl ;
6862 sub isa_perl {
6863   my($self) = @_;
6864   my $file = File::Basename::basename($self->id);
6865   if ($file =~ m{ ^ perl
6866                   -?
6867                   (5)
6868                   ([._-])
6869                   (
6870                    \d{3}(_[0-4][0-9])?
6871                    |
6872                    \d+\.\d+
6873                   )
6874                   \.tar[._-](?:gz|bz2)
6875                   (?!\n)\Z
6876                 }xs){
6877     return "$1.$3";
6878   } elsif ($self->cpan_comment
6879            &&
6880            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6881     return $1;
6882   }
6883 }
6884
6885
6886 #-> sub CPAN::Distribution::perl ;
6887 sub perl {
6888     my ($self) = @_;
6889     if (! $self) {
6890         use Carp qw(carp);
6891         carp __PACKAGE__ . "::perl was called without parameters.";
6892     }
6893     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6894 }
6895
6896
6897 #-> sub CPAN::Distribution::make ;
6898 sub make {
6899     my($self) = @_;
6900     if (my $goto = $self->prefs->{goto}) {
6901         return $self->goto($goto);
6902     }
6903     my $make = $self->{modulebuild} ? "Build" : "make";
6904     # Emergency brake if they said install Pippi and get newest perl
6905     if ($self->isa_perl) {
6906       if (
6907           $self->called_for ne $self->id &&
6908           ! $self->{force_update}
6909          ) {
6910         # if we die here, we break bundles
6911         $CPAN::Frontend
6912             ->mywarn(sprintf(
6913                              qq{The most recent version "%s" of the module "%s"
6914 is part of the perl-%s distribution. To install that, you need to run
6915   force install %s   --or--
6916   install %s
6917 },
6918                              $CPAN::META->instance(
6919                                                    'CPAN::Module',
6920                                                    $self->called_for
6921                                                   )->cpan_version,
6922                              $self->called_for,
6923                              $self->isa_perl,
6924                              $self->called_for,
6925                              $self->id,
6926                             ));
6927         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6928         $CPAN::Frontend->mysleep(1);
6929         return;
6930       }
6931     }
6932     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6933     $self->get;
6934     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6935                            ? $ENV{PERL5LIB}
6936                            : ($ENV{PERLLIB} || "");
6937     $CPAN::META->set_perl5lib;
6938     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6939
6940     if ($CPAN::Signal){
6941       delete $self->{force_update};
6942       return;
6943     }
6944
6945     my $builddir;
6946   EXCUSE: {
6947         my @e;
6948         if (!$self->{archived} || $self->{archived} eq "NO") {
6949             push @e, "Is neither a tar nor a zip archive.";
6950         }
6951
6952         if (!$self->{unwrapped}
6953             || (
6954                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6955                 $self->{unwrapped}->failed :
6956                 $self->{unwrapped} =~ /^NO/
6957                )) {
6958             push @e, "Had problems unarchiving. Please build manually";
6959         }
6960
6961         unless ($self->{force_update}) {
6962             exists $self->{signature_verify} and
6963                 (
6964                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6965                  $self->{signature_verify}->failed :
6966                  $self->{signature_verify} =~ /^NO/
6967                 )
6968                 and push @e, "Did not pass the signature test.";
6969         }
6970
6971         if (exists $self->{writemakefile} &&
6972             (
6973              UNIVERSAL::can($self->{writemakefile},"failed") ?
6974              $self->{writemakefile}->failed :
6975              $self->{writemakefile} =~ /^NO/
6976             )) {
6977             # XXX maybe a retry would be in order?
6978             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6979                 $self->{writemakefile}->text :
6980                     $self->{writemakefile};
6981             $err =~ s/^NO\s*//;
6982             $err ||= "Had some problem writing Makefile";
6983             $err .= ", won't make";
6984             push @e, $err;
6985         }
6986
6987         if (defined $self->{make}) {
6988             if (UNIVERSAL::can($self->{make},"failed") ?
6989                 $self->{make}->failed :
6990                 $self->{make} =~ /^NO/) {
6991                 if ($self->{force_update}) {
6992                     # Trying an already failed 'make' (unless somebody else blocks)
6993                 } else {
6994                     # introduced for turning recursion detection into a distrostatus
6995                     my $error = length $self->{make}>3
6996                         ? substr($self->{make},3) : "Unknown error";
6997                     $CPAN::Frontend->mywarn("Could not make: $error\n");
6998                     $self->store_persistent_state;
6999                     return;
7000                 }
7001             } else {
7002                 push @e, "Has already been made";
7003             }
7004         }
7005
7006         if ($self->{later}) { # see also undelay
7007             if ($self->unsat_prereq) {
7008                 push @e, $self->{later};
7009             }
7010         }
7011
7012         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
7013         $builddir = $self->dir or
7014             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
7015         unless (chdir $builddir) {
7016             push @e, "Couldn't chdir to '$builddir': $!";
7017         }
7018         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
7019     }
7020     if ($CPAN::Signal){
7021       delete $self->{force_update};
7022       return;
7023     }
7024     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
7025     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
7026
7027     if ($^O eq 'MacOS') {
7028         Mac::BuildTools::make($self);
7029         return;
7030     }
7031
7032     my %env;
7033     while (my($k,$v) = each %ENV) {
7034         next unless defined $v;
7035         $env{$k} = $v;
7036     }
7037     local %ENV = %env;
7038     my $system;
7039     if (my $commandline = $self->prefs->{pl}{commandline}) {
7040         $system = $commandline;
7041         $ENV{PERL} = $^X;
7042     } elsif ($self->{'configure'}) {
7043         $system = $self->{'configure'};
7044     } elsif ($self->{modulebuild}) {
7045         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7046         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
7047     } else {
7048         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
7049         my $switch = "";
7050 # This needs a handler that can be turned on or off:
7051 #       $switch = "-MExtUtils::MakeMaker ".
7052 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
7053 #           if $] > 5.00310;
7054         my $makepl_arg = $self->make_x_arg("pl");
7055         $system = sprintf("%s%s Makefile.PL%s",
7056                           $perl,
7057                           $switch ? " $switch" : "",
7058                           $makepl_arg ? " $makepl_arg" : "",
7059                          );
7060     }
7061     if (my $env = $self->prefs->{pl}{env}) {
7062         for my $e (keys %$env) {
7063             $ENV{$e} = $env->{$e};
7064         }
7065     }
7066     if (exists $self->{writemakefile}) {
7067     } else {
7068         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7069         my($ret,$pid);
7070         $@ = "";
7071         my $go_via_alarm;
7072         if ($CPAN::Config->{inactivity_timeout}) {
7073             require Config;
7074             if ($Config::Config{d_alarm}
7075                 &&
7076                 $Config::Config{d_alarm} eq "define"
7077                ) {
7078                 $go_via_alarm++
7079             } else {
7080                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7081                                         "variable 'inactivity_timeout' to ".
7082                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7083                                         "on this machine the system call 'alarm' ".
7084                                         "isn't available. This means that we cannot ".
7085                                         "provide the feature of intercepting long ".
7086                                         "waiting code and will turn this feature off.\n"
7087                                        );
7088                 $CPAN::Config->{inactivity_timeout} = 0;
7089             }
7090         }
7091         if ($go_via_alarm) {
7092             eval {
7093                 alarm $CPAN::Config->{inactivity_timeout};
7094                 local $SIG{CHLD}; # = sub { wait };
7095                 if (defined($pid = fork)) {
7096                     if ($pid) { #parent
7097                         # wait;
7098                         waitpid $pid, 0;
7099                     } else {    #child
7100                         # note, this exec isn't necessary if
7101                         # inactivity_timeout is 0. On the Mac I'd
7102                         # suggest, we set it always to 0.
7103                         exec $system;
7104                     }
7105                 } else {
7106                     $CPAN::Frontend->myprint("Cannot fork: $!");
7107                     return;
7108                 }
7109             };
7110             alarm 0;
7111             if ($@){
7112                 kill 9, $pid;
7113                 waitpid $pid, 0;
7114                 my $err = "$@";
7115                 $CPAN::Frontend->myprint($err);
7116                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7117                 $@ = "";
7118                 return;
7119             }
7120         } else {
7121             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7122                 $ret = $self->_run_via_expect($system,$expect_model);
7123                 if (! defined $ret
7124                     && $self->{writemakefile}
7125                     && $self->{writemakefile}->failed) {
7126                     # timeout
7127                     return;
7128                 }
7129             } else {
7130                 $ret = system($system);
7131             }
7132             if ($ret != 0) {
7133                 $self->{writemakefile} = CPAN::Distrostatus
7134                     ->new("NO '$system' returned status $ret");
7135                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7136                 $self->store_persistent_state;
7137                 return $self->goodbye("$system -- NOT OK\n");
7138             }
7139         }
7140         if (-f "Makefile" || -f "Build") {
7141           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7142           delete $self->{make_clean}; # if cleaned before, enable next
7143         } else {
7144           $self->{writemakefile} = CPAN::Distrostatus
7145               ->new(qq{NO -- Unknown reason});
7146         }
7147     }
7148     if ($CPAN::Signal){
7149       delete $self->{force_update};
7150       return;
7151     }
7152     if (my @prereq = $self->unsat_prereq){
7153         if ($prereq[0][0] eq "perl") {
7154             my $need = "requires perl '$prereq[0][1]'";
7155             my $id = $self->pretty_id;
7156             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7157             $self->{make} = CPAN::Distrostatus->new("NO $need");
7158             $self->store_persistent_state;
7159             return $self->goodbye("[prereq] -- NOT OK\n");
7160         } else {
7161             my $follow = eval { $self->follow_prereqs(@prereq); };
7162             if (0) {
7163             } elsif ($follow){
7164                 # signal success to the queuerunner
7165                 return 1;
7166             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7167                 $CPAN::Frontend->mywarn($@);
7168                 return $self->goodbye("[depend] -- NOT OK\n");
7169             }
7170         }
7171     }
7172     if ($CPAN::Signal){
7173       delete $self->{force_update};
7174       return;
7175     }
7176     if (my $commandline = $self->prefs->{make}{commandline}) {
7177         $system = $commandline;
7178         $ENV{PERL} = $^X;
7179     } else {
7180         if ($self->{modulebuild}) {
7181             unless (-f "Build") {
7182                 my $cwd = CPAN::anycwd();
7183                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7184                                         " in cwd[$cwd]. Danger, Will Robinson!\n");
7185                 $CPAN::Frontend->mysleep(5);
7186             }
7187             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7188         } else {
7189             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7190         }
7191         $system =~ s/\s+$//;
7192         my $make_arg = $self->make_x_arg("make");
7193         $system = sprintf("%s%s",
7194                           $system,
7195                           $make_arg ? " $make_arg" : "",
7196                          );
7197     }
7198     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7199                                                # ENV of PL, not the
7200                                                # outer ENV, but
7201                                                # unlikely to be a risk
7202         for my $e (keys %$env) {
7203             $ENV{$e} = $env->{$e};
7204         }
7205     }
7206     my $expect_model = $self->_prefs_with_expect("make");
7207     my $want_expect = 0;
7208     if ( $expect_model && @{$expect_model->{talk}} ) {
7209         my $can_expect = $CPAN::META->has_inst("Expect");
7210         if ($can_expect) {
7211             $want_expect = 1;
7212         } else {
7213             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7214                                     "system()\n");
7215         }
7216     }
7217     my $system_ok;
7218     if ($want_expect) {
7219         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7220     } else {
7221         $system_ok = system($system) == 0;
7222     }
7223     $self->introduce_myself;
7224     if ( $system_ok ) {
7225          $CPAN::Frontend->myprint("  $system -- OK\n");
7226          $self->{make} = CPAN::Distrostatus->new("YES");
7227     } else {
7228          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7229          $self->{make} = CPAN::Distrostatus->new("NO");
7230          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7231     }
7232     $self->store_persistent_state;
7233 }
7234
7235 # CPAN::Distribution::goodbye ;
7236 sub goodbye {
7237     my($self,$goodbye) = @_;
7238     my $id = $self->pretty_id;
7239     $CPAN::Frontend->mywarn("  $id\n  $goodbye");
7240     return;
7241 }
7242
7243 # CPAN::Distribution::_run_via_expect ;
7244 sub _run_via_expect {
7245     my($self,$system,$expect_model) = @_;
7246     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7247     if ($CPAN::META->has_inst("Expect")) {
7248         my $expo = Expect->new;  # expo Expect object;
7249         $expo->spawn($system);
7250         $expect_model->{mode} ||= "deterministic";
7251         if ($expect_model->{mode} eq "deterministic") {
7252             return $self->_run_via_expect_deterministic($expo,$expect_model);
7253         } elsif ($expect_model->{mode} eq "anyorder") {
7254             return $self->_run_via_expect_anyorder($expo,$expect_model);
7255         } else {
7256             die "Panic: Illegal expect mode: $expect_model->{mode}";
7257         }
7258     } else {
7259         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7260         return system($system);
7261     }
7262 }
7263
7264 sub _run_via_expect_anyorder {
7265     my($self,$expo,$expect_model) = @_;
7266     my $timeout = $expect_model->{timeout} || 5;
7267     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7268     my $but = "";
7269   EXPECT: while () {
7270         my($eof,$ran_into_timeout);
7271         my @match = $expo->expect($timeout,
7272                                   [ eof => sub {
7273                                         $eof++;
7274                                     } ],
7275                                   [ timeout => sub {
7276                                         $ran_into_timeout++;
7277                                     } ],
7278                                   -re => eval"qr{.}",
7279                                  );
7280         if ($match[2]) {
7281             $but .= $match[2];
7282         }
7283         $but .= $expo->clear_accum;
7284         if ($eof) {
7285             $expo->soft_close;
7286             return $expo->exitstatus();
7287         } elsif ($ran_into_timeout) {
7288             # warn "DEBUG: they are asking a question, but[$but]";
7289             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7290                 my($next,$send) = @expectacopy[$i,$i+1];
7291                 my $regex = eval "qr{$next}";
7292                 # warn "DEBUG: will compare with regex[$regex].";
7293                 if ($but =~ /$regex/) {
7294                     # warn "DEBUG: will send send[$send]";
7295                     $expo->send($send);
7296                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7297                     next EXPECT;
7298                 }
7299             }
7300             my $why = "could not answer a question during the dialog";
7301             $CPAN::Frontend->mywarn("Failing: $why\n");
7302             $self->{writemakefile} =
7303                 CPAN::Distrostatus->new("NO $why");
7304             return;
7305         }
7306     }
7307 }
7308
7309 sub _run_via_expect_deterministic {
7310     my($self,$expo,$expect_model) = @_;
7311     my $ran_into_timeout;
7312     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7313     my $expecta = $expect_model->{talk};
7314   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7315         my($re,$send) = @$expecta[$i,$i+1];
7316         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7317         my $regex = eval "qr{$re}";
7318         $expo->expect($timeout,
7319                       [ eof => sub {
7320                             my $but = $expo->clear_accum;
7321                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7322 expected[$regex]\nbut[$but]\n\n");
7323                             last EXPECT;
7324                         } ],
7325                       [ timeout => sub {
7326                             my $but = $expo->clear_accum;
7327                             $CPAN::Frontend->mywarn("TIMEOUT
7328 expected[$regex]\nbut[$but]\n\n");
7329                             $ran_into_timeout++;
7330                         } ],
7331                       -re => $regex);
7332         if ($ran_into_timeout){
7333             # note that the caller expects 0 for success
7334             $self->{writemakefile} =
7335                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7336             return;
7337         }
7338         $expo->send($send);
7339     }
7340     $expo->soft_close;
7341     return $expo->exitstatus();
7342 }
7343
7344 #-> CPAN::Distribution::_validate_distropref
7345 sub _validate_distropref {
7346     my($self,@args) = @_;
7347     if (
7348         $CPAN::META->has_inst("CPAN::Kwalify")
7349         &&
7350         $CPAN::META->has_inst("Kwalify")
7351        ) {
7352         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7353         if ($@) {
7354             $CPAN::Frontend->mywarn($@);
7355         }
7356     } else {
7357         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7358     }
7359 }
7360
7361 #-> CPAN::Distribution::_find_prefs
7362 sub _find_prefs {
7363     my($self) = @_;
7364     my $distroid = $self->pretty_id;
7365     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7366     my $prefs_dir = $CPAN::Config->{prefs_dir};
7367     eval { File::Path::mkpath($prefs_dir); };
7368     if ($@) {
7369         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7370     }
7371     my $yaml_module = CPAN::_yaml_module;
7372     my @extensions;
7373     if ($CPAN::META->has_inst($yaml_module)) {
7374         push @extensions, "yml";
7375     } else {
7376         my @fallbacks;
7377         if ($CPAN::META->has_inst("Data::Dumper")) {
7378             push @extensions, "dd";
7379             push @fallbacks, "Data::Dumper";
7380         }
7381         if ($CPAN::META->has_inst("Storable")) {
7382             push @extensions, "st";
7383             push @fallbacks, "Storable";
7384         }
7385         if (@fallbacks) {
7386             local $" = " and ";
7387             unless ($self->{have_complained_about_missing_yaml}++) {
7388                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7389                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7390             }
7391         } else {
7392             unless ($self->{have_complained_about_missing_yaml}++) {
7393                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7394                                         "read prefs '$prefs_dir'\n");
7395             }
7396         }
7397     }
7398     if (@extensions) {
7399         my $dh = DirHandle->new($prefs_dir)
7400             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7401       DIRENT: for (sort $dh->read) {
7402             next if $_ eq "." || $_ eq "..";
7403             my $exte = join "|", @extensions;
7404             next unless /\.($exte)$/;
7405             my $thisexte = $1;
7406             my $abs = File::Spec->catfile($prefs_dir, $_);
7407             if (-f $abs) {
7408                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7409                 my @distropref;
7410                 if ($thisexte eq "yml") {
7411                     # need no eval because if we have no YAML we do not try to read *.yml
7412                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7413                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7414                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7415                 } elsif ($thisexte eq "dd") {
7416                     package CPAN::Eval;
7417                     no strict;
7418                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7419                     local $/;
7420                     my $eval = <FH>;
7421                     close FH;
7422                     eval $eval;
7423                     if ($@) {
7424                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7425                     }
7426                     my $i = 1;
7427                     while (${"VAR".$i}) {
7428                         push @distropref, ${"VAR".$i};
7429                         $i++;
7430                     }
7431                 } elsif ($thisexte eq "st") {
7432                     # eval because Storable is never forward compatible
7433                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7434                     if ($@) {
7435                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7436                                                 "$_, skipping\: $@");
7437                         $CPAN::Frontend->mysleep(4);
7438                         next DIRENT;
7439                     }
7440                 }
7441                 # $DB::single=1;
7442                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7443               ELEMENT: for my $y (0..$#distropref) {
7444                     my $distropref = $distropref[$y];
7445                     $self->_validate_distropref($distropref,$abs,$y);
7446                     my $match = $distropref->{match};
7447                     unless ($match) {
7448                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7449                         next ELEMENT;
7450                     }
7451                     my $ok = 1;
7452                     # do not take the order of C<keys %$match> because
7453                     # "module" is by far the slowest
7454                     my $saw_valid_subkeys = 0;
7455                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7456                         next unless exists $match->{$sub_attribute};
7457                         $saw_valid_subkeys++;
7458                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7459                         if ($sub_attribute eq "module") {
7460                             my $okm = 0;
7461                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7462                             my @modules = $self->containsmods;
7463                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7464                           MODULE: for my $module (@modules) {
7465                                 $okm ||= $module =~ /$qr/;
7466                                 last MODULE if $okm;
7467                             }
7468                             $ok &&= $okm;
7469                         } elsif ($sub_attribute eq "distribution") {
7470                             my $okd = $distroid =~ /$qr/;
7471                             $ok &&= $okd;
7472                         } elsif ($sub_attribute eq "perl") {
7473                             my $okp = $^X =~ /$qr/;
7474                             $ok &&= $okp;
7475                         } elsif ($sub_attribute eq "perlconfig") {
7476                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7477                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7478                                 # XXX should probably warn if Config does not exist
7479                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7480                                 $ok &&= $okpc;
7481                                 last if $ok == 0;
7482                             }
7483                         } else {
7484                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7485                                                    "unknown sub_attribut '$sub_attribute'. ".
7486                                                    "Please ".
7487                                                    "remove, cannot continue.");
7488                         }
7489                         last if $ok == 0; # short circuit
7490                     }
7491                     unless ($saw_valid_subkeys) {
7492                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7493                                                "missing match/* subattribute. ".
7494                                                "Please ".
7495                                                "remove, cannot continue.");
7496                     }
7497                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7498                     if ($ok) {
7499                         return {
7500                                 prefs => $distropref,
7501                                 prefs_file => $abs,
7502                                 prefs_file_doc => $y,
7503                                };
7504                     }
7505
7506                 }
7507             }
7508         }
7509         $dh->close;
7510     }
7511     return;
7512 }
7513
7514 # CPAN::Distribution::prefs
7515 sub prefs {
7516     my($self) = @_;
7517     if (exists $self->{negative_prefs_cache}
7518         &&
7519         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7520        ) {
7521         delete $self->{negative_prefs_cache};
7522         delete $self->{prefs};
7523     }
7524     if (exists $self->{prefs}) {
7525         return $self->{prefs}; # XXX comment out during debugging
7526     }
7527     if ($CPAN::Config->{prefs_dir}) {
7528         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7529         my $prefs = $self->_find_prefs();
7530         $prefs ||= ""; # avoid warning next line
7531         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7532         if ($prefs) {
7533             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7534                 $self->{$x} = $prefs->{$x};
7535             }
7536             my $bs = sprintf(
7537                              "%s[%s]",
7538                              File::Basename::basename($self->{prefs_file}),
7539                              $self->{prefs_file_doc},
7540                             );
7541             my $filler1 = "_" x 22;
7542             my $filler2 = int(66 - length($bs))/2;
7543             $filler2 = 0 if $filler2 < 0;
7544             $filler2 = " " x $filler2;
7545             $CPAN::Frontend->myprint("
7546 $filler1 D i s t r o P r e f s $filler1
7547 $filler2 $bs $filler2
7548 ");
7549             $CPAN::Frontend->mysleep(1);
7550             return $self->{prefs};
7551         }
7552     }
7553     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7554     return $self->{prefs} = +{};
7555 }
7556
7557 # CPAN::Distribution::make_x_arg
7558 sub make_x_arg {
7559     my($self, $whixh) = @_;
7560     my $make_x_arg;
7561     my $prefs = $self->prefs;
7562     if (
7563         $prefs
7564         && exists $prefs->{$whixh}
7565         && exists $prefs->{$whixh}{args}
7566         && $prefs->{$whixh}{args}
7567        ) {
7568         $make_x_arg = join(" ",
7569                            map {CPAN::HandleConfig
7570                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7571                           );
7572     }
7573     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7574     $make_x_arg ||= $CPAN::Config->{$what};
7575     return $make_x_arg;
7576 }
7577
7578 # CPAN::Distribution::_make_command
7579 sub _make_command {
7580     my ($self) = @_;
7581     if ($self) {
7582         return
7583             CPAN::HandleConfig
7584                 ->safe_quote(
7585                              CPAN::HandleConfig->prefs_lookup($self,
7586                                                               q{make})
7587                              || $Config::Config{make}
7588                              || 'make'
7589                             );
7590     } else {
7591         # Old style call, without object. Deprecated
7592         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7593         return
7594           safe_quote(undef,
7595                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7596                      || $CPAN::Config->{make}
7597                      || $Config::Config{make}
7598                      || 'make');
7599     }
7600 }
7601
7602 #-> sub CPAN::Distribution::follow_prereqs ;
7603 sub follow_prereqs {
7604     my($self) = shift;
7605     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7606     return unless @prereq_tuples;
7607     my @prereq = map { $_->[0] } @prereq_tuples;
7608     my $pretty_id = $self->pretty_id;
7609     my %map = (
7610                b => "build_requires",
7611                r => "requires",
7612                c => "commandline",
7613               );
7614     my($filler1,$filler2,$filler3,$filler4);
7615     # $DB::single=1;
7616     my $unsat = "Unsatisfied dependencies detected during";
7617     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7618     {
7619         my $r = int(($w - length($unsat))/2);
7620         my $l = $w - length($unsat) - $r;
7621         $filler1 = "-"x4 . " "x$l;
7622         $filler2 = " "x$r . "-"x4 . "\n";
7623     }
7624     {
7625         my $r = int(($w - length($pretty_id))/2);
7626         my $l = $w - length($pretty_id) - $r;
7627         $filler3 = "-"x4 . " "x$l;
7628         $filler4 = " "x$r . "-"x4 . "\n";
7629     }
7630     $CPAN::Frontend->
7631         myprint("$filler1 $unsat $filler2".
7632                 "$filler3 $pretty_id $filler4".
7633                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7634                );
7635     my $follow = 0;
7636     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7637         $follow = 1;
7638     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7639         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7640 "Shall I follow them and prepend them to the queue
7641 of modules we are processing right now?", "yes");
7642         $follow = $answer =~ /^\s*y/i;
7643     } else {
7644         local($") = ", ";
7645         $CPAN::Frontend->
7646             myprint("  Ignoring dependencies on modules @prereq\n");
7647     }
7648     if ($follow) {
7649         my $id = $self->id;
7650         # color them as dirty
7651         for my $p (@prereq) {
7652             # warn "calling color_cmd_tmps(0,1)";
7653             my $any = CPAN::Shell->expandany($p);
7654             if ($any) {
7655                 $any->color_cmd_tmps(0,2);
7656             } else {
7657                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7658                 $CPAN::Frontend->mysleep(2);
7659             }
7660         }
7661         # queue them and re-queue yourself
7662         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7663                                reverse @prereq_tuples);
7664         $self->{later} = "Delayed until after prerequisites";
7665         return 1; # signal success to the queuerunner
7666     }
7667 }
7668
7669 #-> sub CPAN::Distribution::unsat_prereq ;
7670 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7671 # return ([perl=>5.008]) if we need a newer perl than we are running under
7672 sub unsat_prereq {
7673     my($self) = @_;
7674     my $prereq_pm = $self->prereq_pm or return;
7675     my(@need);
7676     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7677     my @merged = %merged;
7678     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7679   NEED: while (my($need_module, $need_version) = each %merged) {
7680         my($available_version,$available_file,$nmo);
7681         if ($need_module eq "perl") {
7682             $available_version = $];
7683             $available_file = $^X;
7684         } else {
7685             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7686             next if $nmo->uptodate;
7687             $available_file = $nmo->available_file;
7688
7689             # if they have not specified a version, we accept any installed one
7690             if (defined $available_file
7691                 and ( # a few quick shortcurcuits
7692                      not defined $need_version
7693                      or $need_version eq '0'    # "==" would trigger warning when not numeric
7694                      or $need_version eq "undef"
7695                     )) {
7696                 next NEED;
7697             }
7698
7699             $available_version = $nmo->available_version;
7700         }
7701
7702         # We only want to install prereqs if either they're not installed
7703         # or if the installed version is too old. We cannot omit this
7704         # check, because if 'force' is in effect, nobody else will check.
7705         if (defined $available_file) {
7706             my(@all_requirements) = split /\s*,\s*/, $need_version;
7707             local($^W) = 0;
7708             my $ok = 0;
7709           RQ: for my $rq (@all_requirements) {
7710                 if ($rq =~ s|>=\s*||) {
7711                 } elsif ($rq =~ s|>\s*||) {
7712                     # 2005-12: one user
7713                     if (CPAN::Version->vgt($available_version,$rq)){
7714                         $ok++;
7715                     }
7716                     next RQ;
7717                 } elsif ($rq =~ s|!=\s*||) {
7718                     # 2005-12: no user
7719                     if (CPAN::Version->vcmp($available_version,$rq)){
7720                         $ok++;
7721                         next RQ;
7722                     } else {
7723                         last RQ;
7724                     }
7725                 } elsif ($rq =~ m|<=?\s*|) {
7726                     # 2005-12: no user
7727                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7728                     $ok++;
7729                     next RQ;
7730                 }
7731                 if (! CPAN::Version->vgt($rq, $available_version)){
7732                     $ok++;
7733                 }
7734                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7735                                     "available_version[%s]rq[%s]ok[%d]",
7736                                     $need_module,
7737                                     $available_file,
7738                                     $available_version,
7739                                     CPAN::Version->readable($rq),
7740                                     $ok,
7741                                    )) if $CPAN::DEBUG;
7742             }
7743             next NEED if $ok == @all_requirements;
7744         }
7745
7746         if ($need_module eq "perl") {
7747             return ["perl", $need_version];
7748         }
7749         if ($self->{sponsored_mods}{$need_module}++){
7750             # We have already sponsored it and for some reason it's still
7751             # not available. So we do ... what??
7752
7753             # if we push it again, we have a potential infinite loop
7754
7755             # The following "next" was a very problematic construct.
7756             # It helped a lot but broke some day and had to be
7757             # replaced.
7758
7759             # We must be able to deal with modules that come again and
7760             # again as a prereq and have themselves prereqs and the
7761             # queue becomes long but finally we would find the correct
7762             # order. The RecursiveDependency check should trigger a
7763             # die when it's becoming too weird. Unfortunately removing
7764             # this next breaks many other things.
7765
7766             # The bug that brought this up is described in Todo under
7767             # "5.8.9 cannot install Compress::Zlib"
7768
7769             # next; # this is the next that had to go away
7770
7771             # The following "next NEED" are fine and the error message
7772             # explains well what is going on. For example when the DBI
7773             # fails and consequently DBD::SQLite fails and now we are
7774             # processing CPAN::SQLite. Then we must have a "next" for
7775             # DBD::SQLite. How can we get it and how can we identify
7776             # all other cases we must identify?
7777
7778             my $do = $nmo->distribution;
7779             next NEED unless $do; # not on CPAN
7780           NOSAYER: for my $nosayer (
7781                                     "unwrapped",
7782                                     "writemakefile",
7783                                     "signature_verify",
7784                                     "make",
7785                                     "make_test",
7786                                     "install",
7787                                     "make_clean",
7788                                    ) {
7789                 if ($do->{$nosayer}) {
7790                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
7791                         $do->{$nosayer}->failed :
7792                         $do->{$nosayer} =~ /^NO/) {
7793                         if ($nosayer eq "make_test"
7794                             &&
7795                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7796                            ) {
7797                             next NOSAYER;
7798                         }
7799                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7800                                                 "'$need_module => $need_version' ".
7801                                                 "for '$self->{ID}' failed when ".
7802                                                 "processing '$do->{ID}' with ".
7803                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
7804                                                 "but chances to succeed are limited.\n"
7805                                                );
7806                         next NEED;
7807                     } else { # the other guy succeeded
7808                         if ($nosayer eq "install") {
7809                             # we had this with
7810                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
7811                             # 2007-03
7812                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7813                                                     "'$need_module => $need_version' ".
7814                                                     "for '$self->{ID}' already installed ".
7815                                                     "but installation looks suspicious. ".
7816                                                     "Skipping another installation attempt, ".
7817                                                     "to prevent looping endlessly.\n"
7818                                                    );
7819                             next NEED;
7820                         }
7821                     }
7822                 }
7823             }
7824         }
7825         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7826         push @need, [$need_module,$needed_as];
7827     }
7828     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7829     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7830     @need;
7831 }
7832
7833 #-> sub CPAN::Distribution::read_yaml ;
7834 sub read_yaml {
7835     my($self) = @_;
7836     return $self->{yaml_content} if exists $self->{yaml_content};
7837     my $build_dir = $self->{build_dir};
7838     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7839     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7840     return unless -f $yaml;
7841     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7842     if ($@) {
7843         $CPAN::Frontend->mywarn("Could not read ".
7844                                 "'$yaml'. Falling back to other ".
7845                                 "methods to determine prerequisites\n");
7846         return $self->{yaml_content} = undef; # if we die, then we
7847                                               # cannot read YAML's own
7848                                               # META.yml
7849     }
7850     # not "authoritative"
7851     if (not exists $self->{yaml_content}{dynamic_config}
7852         or $self->{yaml_content}{dynamic_config}
7853        ) {
7854         $self->{yaml_content} = undef;
7855     }
7856     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7857         if $CPAN::DEBUG;
7858     return $self->{yaml_content};
7859 }
7860
7861 #-> sub CPAN::Distribution::prereq_pm ;
7862 sub prereq_pm {
7863     my($self) = @_;
7864     $self->{prereq_pm_detected} ||= 0;
7865     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7866     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7867     return unless $self->{writemakefile}  # no need to have succeeded
7868                                           # but we must have run it
7869         || $self->{modulebuild};
7870     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7871                 $self->{writemakefile}||"",
7872                 $self->{modulebuild}||"",
7873                ) if $CPAN::DEBUG;
7874     my($req,$breq);
7875     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7876         $req =  $yaml->{requires} || {};
7877         $breq =  $yaml->{build_requires} || {};
7878         undef $req unless ref $req eq "HASH" && %$req;
7879         if ($req) {
7880             if ($yaml->{generated_by} &&
7881                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7882                 my $eummv = do { local $^W = 0; $1+0; };
7883                 if ($eummv < 6.2501) {
7884                     # thanks to Slaven for digging that out: MM before
7885                     # that could be wrong because it could reflect a
7886                     # previous release
7887                     undef $req;
7888                 }
7889             }
7890             my $areq;
7891             my $do_replace;
7892             while (my($k,$v) = each %{$req||{}}) {
7893                 if ($v =~ /\d/) {
7894                     $areq->{$k} = $v;
7895                 } elsif ($k =~ /[A-Za-z]/ &&
7896                          $v =~ /[A-Za-z]/ &&
7897                          $CPAN::META->exists("Module",$v)
7898                         ) {
7899                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7900                                             "requires hash: $k => $v; I'll take both ".
7901                                             "key and value as a module name\n");
7902                     $CPAN::Frontend->mysleep(1);
7903                     $areq->{$k} = 0;
7904                     $areq->{$v} = 0;
7905                     $do_replace++;
7906                 }
7907             }
7908             $req = $areq if $do_replace;
7909         }
7910     }
7911     unless ($req || $breq) {
7912         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7913         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7914         my $fh;
7915         if (-f $makefile
7916             and
7917             $fh = FileHandle->new("<$makefile\0")) {
7918             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7919             local($/) = "\n";
7920             while (<$fh>) {
7921                 last if /MakeMaker post_initialize section/;
7922                 my($p) = m{^[\#]
7923                            \s+PREREQ_PM\s+=>\s+(.+)
7924                        }x;
7925                 next unless $p;
7926                 # warn "Found prereq expr[$p]";
7927
7928                 #  Regexp modified by A.Speer to remember actual version of file
7929                 #  PREREQ_PM hash key wants, then add to
7930                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7931                     # In case a prereq is mentioned twice, complain.
7932                     if ( defined $req->{$1} ) {
7933                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7934                             "last mention wins";
7935                     }
7936                     my($m,$n) = ($1,$2);
7937                     if ($n =~ /^q\[(.*?)\]$/) {
7938                         $n = $1;
7939                     }
7940                     $req->{$m} = $n;
7941                 }
7942                 last;
7943             }
7944         }
7945     }
7946     unless ($req || $breq) {
7947         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7948         my $buildfile = File::Spec->catfile($build_dir,"Build");
7949         if (-f $buildfile) {
7950             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7951             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7952             if (-f $build_prereqs) {
7953                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7954                 my $content = do { local *FH;
7955                                    open FH, $build_prereqs
7956                                        or $CPAN::Frontend->mydie("Could not open ".
7957                                                                  "'$build_prereqs': $!");
7958                                    local $/;
7959                                    <FH>;
7960                                };
7961                 my $bphash = eval $content;
7962                 if ($@) {
7963                 } else {
7964                     $req  = $bphash->{requires} || +{};
7965                     $breq = $bphash->{build_requires} || +{};
7966                 }
7967             }
7968         }
7969     }
7970     if (-f "Build.PL"
7971         && ! -f "Makefile.PL"
7972         && ! exists $req->{"Module::Build"}
7973         && ! $CPAN::META->has_inst("Module::Build")) {
7974         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7975                                 "undeclared prerequisite.\n".
7976                                 "  Adding it now as such.\n"
7977                                );
7978         $CPAN::Frontend->mysleep(5);
7979         $req->{"Module::Build"} = 0;
7980         delete $self->{writemakefile};
7981     }
7982     if ($req || $breq) {
7983         $self->{prereq_pm_detected}++;
7984         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7985     }
7986 }
7987
7988 #-> sub CPAN::Distribution::test ;
7989 sub test {
7990     my($self) = @_;
7991     if (my $goto = $self->prefs->{goto}) {
7992         return $self->goto($goto);
7993     }
7994     $self->make;
7995     if ($CPAN::Signal){
7996       delete $self->{force_update};
7997       return;
7998     }
7999     # warn "XDEBUG: checking for notest: $self->{notest} $self";
8000     if ($self->{notest}) {
8001         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
8002         return 1;
8003     }
8004
8005     my $make = $self->{modulebuild} ? "Build" : "make";
8006
8007     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
8008                            ? $ENV{PERL5LIB}
8009                            : ($ENV{PERLLIB} || "");
8010
8011     $CPAN::META->set_perl5lib;
8012     local $ENV{MAKEFLAGS}; # protect us from outer make calls
8013
8014     $CPAN::Frontend->myprint("Running $make test\n");
8015
8016 #    if (my @prereq = $self->unsat_prereq){
8017 #        if ( $CPAN::DEBUG ) {
8018 #            require Data::Dumper;
8019 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
8020 #        }
8021 #        unless ($prereq[0][0] eq "perl") {
8022 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
8023 #        }
8024 #    }
8025
8026   EXCUSE: {
8027         my @e;
8028         if ($self->{make} or $self->{later}) {
8029             # go ahead
8030         } else {
8031             push @e,
8032                 "Make had some problems, won't test";
8033         }
8034
8035         exists $self->{make} and
8036             (
8037              UNIVERSAL::can($self->{make},"failed") ?
8038              $self->{make}->failed :
8039              $self->{make} =~ /^NO/
8040             ) and push @e, "Can't test without successful make";
8041         $self->{badtestcnt} ||= 0;
8042         if ($self->{badtestcnt} > 0) {
8043             require Data::Dumper;
8044             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
8045             push @e, "Won't repeat unsuccessful test during this command";
8046         }
8047
8048         push @e, $self->{later} if $self->{later};
8049
8050         if (exists $self->{build_dir}) {
8051             if (exists $self->{make_test}) {
8052                 if (
8053                     UNIVERSAL::can($self->{make_test},"failed") ?
8054                     $self->{make_test}->failed :
8055                     $self->{make_test} =~ /^NO/
8056                    ) {
8057                     if (
8058                         UNIVERSAL::can($self->{make_test},"commandid")
8059                         &&
8060                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
8061                        ) {
8062                         push @e, "Has already been tested within this command";
8063                     }
8064                 } else {
8065                     push @e, "Has already been tested successfully";
8066                 }
8067             }
8068         } elsif (!@e) {
8069             push @e, "Has no own directory";
8070         }
8071         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8072         unless (chdir $self->{build_dir}) {
8073             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8074         }
8075         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8076     }
8077     $self->debug("Changed directory to $self->{build_dir}")
8078         if $CPAN::DEBUG;
8079
8080     if ($^O eq 'MacOS') {
8081         Mac::BuildTools::make_test($self);
8082         return;
8083     }
8084
8085     if ($self->{modulebuild}) {
8086         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8087         if (CPAN::Version->vlt($v,2.62)) {
8088             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8089   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8090             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8091             return;
8092         }
8093     }
8094
8095     my $system;
8096     if (my $commandline = $self->prefs->{test}{commandline}) {
8097         $system = $commandline;
8098         $ENV{PERL} = $^X;
8099     } elsif ($self->{modulebuild}) {
8100         $system = sprintf "%s test", $self->_build_command();
8101     } else {
8102         $system = join " ", $self->_make_command(), "test";
8103     }
8104     my $make_test_arg = $self->make_x_arg("test");
8105     $system = sprintf("%s%s",
8106                       $system,
8107                       $make_test_arg ? " $make_test_arg" : "",
8108                      );
8109     my($tests_ok);
8110     my %env;
8111     while (my($k,$v) = each %ENV) {
8112         next unless defined $v;
8113         $env{$k} = $v;
8114     }
8115     local %ENV = %env;
8116     if (my $env = $self->prefs->{test}{env}) {
8117         for my $e (keys %$env) {
8118             $ENV{$e} = $env->{$e};
8119         }
8120     }
8121     my $expect_model = $self->_prefs_with_expect("test");
8122     my $want_expect = 0;
8123     if ( $expect_model && @{$expect_model->{talk}} ) {
8124         my $can_expect = $CPAN::META->has_inst("Expect");
8125         if ($can_expect) {
8126             $want_expect = 1;
8127         } else {
8128             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8129                                     "testing without\n");
8130         }
8131     }
8132     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8133                                                        q{test_report});
8134     my $want_report;
8135     if ($test_report) {
8136         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8137         if ($can_report) {
8138             $want_report = 1;
8139         } else {
8140             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8141                                     "testing without\n");
8142         }
8143     }
8144     my $ready_to_report = $want_report;
8145     if ($ready_to_report
8146         && $self->is_dot_dist
8147        ) {
8148         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8149                                 "for local directories\n");
8150         $ready_to_report = 0;
8151     }
8152     if ($ready_to_report
8153         &&
8154         $self->prefs->{patches}
8155         &&
8156         @{$self->prefs->{patches}}
8157         &&
8158         $self->{patched}
8159        ) {
8160         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8161                                 "when the source has been patched\n");
8162         $ready_to_report = 0;
8163     }
8164     if ($want_expect) {
8165         if ($ready_to_report) {
8166             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8167                                     "not supported when distroprefs specify ".
8168                                     "an interactive test\n");
8169         }
8170         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8171     } elsif ( $ready_to_report ) {
8172         $tests_ok = CPAN::Reporter::test($self, $system);
8173     } else {
8174         $tests_ok = system($system) == 0;
8175     }
8176     $self->introduce_myself;
8177     if ( $tests_ok ) {
8178         {
8179             my @prereq;
8180
8181             # local $CPAN::DEBUG = 16; # Distribution
8182             for my $m (keys %{$self->{sponsored_mods}}) {
8183                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8184                 # XXX we need available_version which reflects
8185                 # $ENV{PERL5LIB} so that already tested but not yet
8186                 # installed modules are counted.
8187                 my $available_version = $m_obj->available_version;
8188                 my $available_file = $m_obj->available_file;
8189                 if ($available_version &&
8190                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8191                    ) {
8192                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8193                         if $CPAN::DEBUG;
8194                 } elsif ($available_file
8195                          && (
8196                              !$self->{prereq_pm}{$m}
8197                              ||
8198                              $self->{prereq_pm}{$m} == 0
8199                             )
8200                         ) {
8201                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8202                     CPAN->debug("m[$m] have available_file[$available_file]")
8203                         if $CPAN::DEBUG;
8204                 } else {
8205                     push @prereq, $m;
8206                 }
8207             }
8208             if (@prereq){
8209                 my $cnt = @prereq;
8210                 my $which = join ",", @prereq;
8211                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8212                     "$cnt dependencies missing ($which)";
8213                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8214                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8215                 $self->store_persistent_state;
8216                 return $self->goodbye("[dependencies] -- NA");
8217             }
8218         }
8219
8220         $CPAN::Frontend->myprint("  $system -- OK\n");
8221         $self->{make_test} = CPAN::Distrostatus->new("YES");
8222         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8223         # probably impossible to need the next line because badtestcnt
8224         # has a lifespan of one command
8225         delete $self->{badtestcnt};
8226     } else {
8227         $self->{make_test} = CPAN::Distrostatus->new("NO");
8228         $self->{badtestcnt}++;
8229         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8230     }
8231     $self->store_persistent_state;
8232 }
8233
8234 sub _prefs_with_expect {
8235     my($self,$where) = @_;
8236     return unless my $prefs = $self->prefs;
8237     return unless my $where_prefs = $prefs->{$where};
8238     if ($where_prefs->{expect}) {
8239         return {
8240                 mode => "deterministic",
8241                 timeout => 15,
8242                 talk => $where_prefs->{expect},
8243                };
8244     } elsif ($where_prefs->{"eexpect"}) {
8245         return $where_prefs->{"eexpect"};
8246     }
8247     return;
8248 }
8249
8250 #-> sub CPAN::Distribution::clean ;
8251 sub clean {
8252     my($self) = @_;
8253     my $make = $self->{modulebuild} ? "Build" : "make";
8254     $CPAN::Frontend->myprint("Running $make clean\n");
8255     unless (exists $self->{archived}) {
8256         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8257                                 "/untarred, nothing done\n");
8258         return 1;
8259     }
8260     unless (exists $self->{build_dir}) {
8261         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8262         return 1;
8263     }
8264     if (exists $self->{writemakefile}
8265         and $self->{writemakefile}->failed
8266        ) {
8267         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8268         return 1;
8269     }
8270   EXCUSE: {
8271         my @e;
8272         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8273             push @e, "make clean already called once";
8274         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8275     }
8276     chdir $self->{build_dir} or
8277         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8278     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8279
8280     if ($^O eq 'MacOS') {
8281         Mac::BuildTools::make_clean($self);
8282         return;
8283     }
8284
8285     my $system;
8286     if ($self->{modulebuild}) {
8287         unless (-f "Build") {
8288             my $cwd = CPAN::anycwd();
8289             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8290                                     " in cwd[$cwd]. Danger, Will Robinson!");
8291             $CPAN::Frontend->mysleep(5);
8292         }
8293         $system = sprintf "%s clean", $self->_build_command();
8294     } else {
8295         $system  = join " ", $self->_make_command(), "clean";
8296     }
8297     my $system_ok = system($system) == 0;
8298     $self->introduce_myself;
8299     if ( $system_ok ) {
8300       $CPAN::Frontend->myprint("  $system -- OK\n");
8301
8302       # $self->force;
8303
8304       # Jost Krieger pointed out that this "force" was wrong because
8305       # it has the effect that the next "install" on this distribution
8306       # will untar everything again. Instead we should bring the
8307       # object's state back to where it is after untarring.
8308
8309       for my $k (qw(
8310                     force_update
8311                     install
8312                     writemakefile
8313                     make
8314                     make_test
8315                    )) {
8316           delete $self->{$k};
8317       }
8318       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8319
8320     } else {
8321       # Hmmm, what to do if make clean failed?
8322
8323       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8324       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8325
8326       # 2006-02-27: seems silly to me to force a make now
8327       # $self->force("make"); # so that this directory won't be used again
8328
8329     }
8330     $self->store_persistent_state;
8331 }
8332
8333 #-> sub CPAN::Distribution::goto ;
8334 sub goto {
8335     my($self,$goto) = @_;
8336     $goto = $self->normalize($goto);
8337
8338     # inject into the queue
8339
8340     CPAN::Queue->delete($self->id);
8341     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8342
8343     # and run where we left off
8344
8345     my($method) = (caller(1))[3];
8346     CPAN->instance("CPAN::Distribution",$goto)->$method();
8347     CPAN::Queue->delete_first($goto);
8348 }
8349
8350 #-> sub CPAN::Distribution::install ;
8351 sub install {
8352     my($self) = @_;
8353     if (my $goto = $self->prefs->{goto}) {
8354         return $self->goto($goto);
8355     }
8356     # $DB::single=1;
8357     unless ($self->{badtestcnt}) {
8358         $self->test;
8359     }
8360     if ($CPAN::Signal){
8361       delete $self->{force_update};
8362       return;
8363     }
8364     my $make = $self->{modulebuild} ? "Build" : "make";
8365     $CPAN::Frontend->myprint("Running $make install\n");
8366   EXCUSE: {
8367         my @e;
8368         if ($self->{make} or $self->{later}) {
8369             # go ahead
8370         } else {
8371             push @e,
8372                 "Make had some problems, won't install";
8373         }
8374
8375         exists $self->{make} and
8376             (
8377              UNIVERSAL::can($self->{make},"failed") ?
8378              $self->{make}->failed :
8379              $self->{make} =~ /^NO/
8380             ) and
8381                 push @e, "Make had returned bad status, install seems impossible";
8382
8383         if (exists $self->{build_dir}) {
8384         } elsif (!@e) {
8385             push @e, "Has no own directory";
8386         }
8387
8388         if (exists $self->{make_test} and
8389             (
8390              UNIVERSAL::can($self->{make_test},"failed") ?
8391              $self->{make_test}->failed :
8392              $self->{make_test} =~ /^NO/
8393             )){
8394             if ($self->{force_update}) {
8395                 $self->{make_test}->text("FAILED but failure ignored because ".
8396                                          "'force' in effect");
8397             } else {
8398                 push @e, "make test had returned bad status, ".
8399                     "won't install without force"
8400             }
8401         }
8402         if (exists $self->{install}) {
8403             if (UNIVERSAL::can($self->{install},"text") ?
8404                 $self->{install}->text eq "YES" :
8405                 $self->{install} =~ /^YES/
8406                ) {
8407                 $CPAN::Frontend->myprint("  Already done\n");
8408                 $CPAN::META->is_installed($self->{build_dir});
8409                 return 1;
8410             } else {
8411                 # comment in Todo on 2006-02-11; maybe retry?
8412                 push @e, "Already tried without success";
8413             }
8414         }
8415
8416         push @e, $self->{later} if $self->{later};
8417
8418         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8419         unless (chdir $self->{build_dir}) {
8420             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8421         }
8422         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8423     }
8424     $self->debug("Changed directory to $self->{build_dir}")
8425         if $CPAN::DEBUG;
8426
8427     if ($^O eq 'MacOS') {
8428         Mac::BuildTools::make_install($self);
8429         return;
8430     }
8431
8432     my $system;
8433     if (my $commandline = $self->prefs->{install}{commandline}) {
8434         $system = $commandline;
8435         $ENV{PERL} = $^X;
8436     } elsif ($self->{modulebuild}) {
8437         my($mbuild_install_build_command) =
8438             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8439                 $CPAN::Config->{mbuild_install_build_command} ?
8440                     $CPAN::Config->{mbuild_install_build_command} :
8441                         $self->_build_command();
8442         $system = sprintf("%s install %s",
8443                           $mbuild_install_build_command,
8444                           $CPAN::Config->{mbuild_install_arg},
8445                          );
8446     } else {
8447         my($make_install_make_command) =
8448             CPAN::HandleConfig->prefs_lookup($self,
8449                                              q{make_install_make_command})
8450                   || $self->_make_command();
8451         $system = sprintf("%s install %s",
8452                           $make_install_make_command,
8453                           $CPAN::Config->{make_install_arg},
8454                          );
8455     }
8456
8457     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8458     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8459                                                 q{build_requires_install_policy});
8460     $brip ||="ask/yes";
8461     my $id = $self->id;
8462     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8463     my $want_install = "yes";
8464     if ($reqtype eq "b") {
8465         if ($brip eq "no") {
8466             $want_install = "no";
8467         } elsif ($brip =~ m|^ask/(.+)|) {
8468             my $default = $1;
8469             $default = "yes" unless $default =~ /^(y|n)/i;
8470             $want_install =
8471                 CPAN::Shell::colorable_makemaker_prompt
8472                       ("$id is just needed temporarily during building or testing. ".
8473                        "Do you want to install it permanently? (Y/n)",
8474                        $default);
8475         }
8476     }
8477     unless ($want_install =~ /^y/i) {
8478         my $is_only = "is only 'build_requires'";
8479         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8480         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8481         delete $self->{force_update};
8482         return;
8483     }
8484     my($pipe) = FileHandle->new("$system $stderr |");
8485     my($makeout) = "";
8486     while (<$pipe>){
8487         print $_; # intentionally NOT use Frontend->myprint because it
8488                   # looks irritating when we markup in color what we
8489                   # just pass through from an external program
8490         $makeout .= $_;
8491     }
8492     $pipe->close;
8493     my $close_ok = $? == 0;
8494     $self->introduce_myself;
8495     if ( $close_ok ) {
8496         $CPAN::Frontend->myprint("  $system -- OK\n");
8497         $CPAN::META->is_installed($self->{build_dir});
8498         $self->{install} = CPAN::Distrostatus->new("YES");
8499     } else {
8500         $self->{install} = CPAN::Distrostatus->new("NO");
8501         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8502         my $mimc =
8503             CPAN::HandleConfig->prefs_lookup($self,
8504                                              q{make_install_make_command});
8505         if (
8506             $makeout =~ /permission/s
8507             && $> > 0
8508             && (
8509                 ! $mimc
8510                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8511                                                               q{make}))
8512                )
8513            ) {
8514             $CPAN::Frontend->myprint(
8515                                      qq{----\n}.
8516                                      qq{  You may have to su }.
8517                                      qq{to root to install the package\n}.
8518                                      qq{  (Or you may want to run something like\n}.
8519                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8520                                      qq{  to raise your permissions.}
8521                                     );
8522         }
8523     }
8524     delete $self->{force_update};
8525     # $DB::single = 1;
8526     $self->store_persistent_state;
8527 }
8528
8529 sub introduce_myself {
8530     my($self) = @_;
8531     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8532 }
8533
8534 #-> sub CPAN::Distribution::dir ;
8535 sub dir {
8536     shift->{build_dir};
8537 }
8538
8539 #-> sub CPAN::Distribution::perldoc ;
8540 sub perldoc {
8541     my($self) = @_;
8542
8543     my($dist) = $self->id;
8544     my $package = $self->called_for;
8545
8546     $self->_display_url( $CPAN::Defaultdocs . $package );
8547 }
8548
8549 #-> sub CPAN::Distribution::_check_binary ;
8550 sub _check_binary {
8551     my ($dist,$shell,$binary) = @_;
8552     my ($pid,$out);
8553
8554     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8555       if $CPAN::DEBUG;
8556
8557     if ($CPAN::META->has_inst("File::Which")) {
8558         return File::Which::which($binary);
8559     } else {
8560         local *README;
8561         $pid = open README, "which $binary|"
8562             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8563         return unless $pid;
8564         while (<README>) {
8565             $out .= $_;
8566         }
8567         close README
8568             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8569                 and return;
8570     }
8571
8572     $CPAN::Frontend->myprint(qq{   + $out \n})
8573       if $CPAN::DEBUG && $out;
8574
8575     return $out;
8576 }
8577
8578 #-> sub CPAN::Distribution::_display_url ;
8579 sub _display_url {
8580     my($self,$url) = @_;
8581     my($res,$saved_file,$pid,$out);
8582
8583     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8584       if $CPAN::DEBUG;
8585
8586     # should we define it in the config instead?
8587     my $html_converter = "html2text";
8588
8589     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8590     my $web_browser_out = $web_browser
8591       ? CPAN::Distribution->_check_binary($self,$web_browser)
8592         : undef;
8593
8594     if ($web_browser_out) {
8595         # web browser found, run the action
8596         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8597         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8598           if $CPAN::DEBUG;
8599         $CPAN::Frontend->myprint(qq{
8600 Displaying URL
8601   $url
8602 with browser $browser
8603 });
8604         $CPAN::Frontend->mysleep(1);
8605         system("$browser $url");
8606         if ($saved_file) { 1 while unlink($saved_file) }
8607     } else {
8608         # web browser not found, let's try text only
8609         my $html_converter_out =
8610           CPAN::Distribution->_check_binary($self,$html_converter);
8611         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8612
8613         if ($html_converter_out ) {
8614             # html2text found, run it
8615             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8616             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8617                 unless defined($saved_file);
8618
8619             local *README;
8620             $pid = open README, "$html_converter $saved_file |"
8621               or $CPAN::Frontend->mydie(qq{
8622 Could not fork '$html_converter $saved_file': $!});
8623             my($fh,$filename);
8624             if ($CPAN::META->has_inst("File::Temp")) {
8625                 $fh = File::Temp->new(
8626                                       dir      => File::Spec->tmpdir,
8627                                       template => 'cpan_htmlconvert_XXXX',
8628                                       suffix => '.txt',
8629                                       unlink => 0,
8630                                      );
8631                 $filename = $fh->filename;
8632             } else {
8633                 $filename = "cpan_htmlconvert_$$.txt";
8634                 $fh = FileHandle->new();
8635                 open $fh, ">$filename" or die;
8636             }
8637             while (<README>) {
8638                 $fh->print($_);
8639             }
8640             close README or
8641                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8642             my $tmpin = $fh->filename;
8643             $CPAN::Frontend->myprint(sprintf(qq{
8644 Run '%s %s' and
8645 saved output to %s\n},
8646                                              $html_converter,
8647                                              $saved_file,
8648                                              $tmpin,
8649                                             )) if $CPAN::DEBUG;
8650             close $fh;
8651             local *FH;
8652             open FH, $tmpin
8653                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8654             my $fh_pager = FileHandle->new;
8655             local($SIG{PIPE}) = "IGNORE";
8656             my $pager = $CPAN::Config->{'pager'} || "cat";
8657             $fh_pager->open("|$pager")
8658                 or $CPAN::Frontend->mydie(qq{
8659 Could not open pager '$pager': $!});
8660             $CPAN::Frontend->myprint(qq{
8661 Displaying URL
8662   $url
8663 with pager "$pager"
8664 });
8665             $CPAN::Frontend->mysleep(1);
8666             $fh_pager->print(<FH>);
8667             $fh_pager->close;
8668         } else {
8669             # coldn't find the web browser or html converter
8670             $CPAN::Frontend->myprint(qq{
8671 You need to install lynx or $html_converter to use this feature.});
8672         }
8673     }
8674 }
8675
8676 #-> sub CPAN::Distribution::_getsave_url ;
8677 sub _getsave_url {
8678     my($dist, $shell, $url) = @_;
8679
8680     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8681       if $CPAN::DEBUG;
8682
8683     my($fh,$filename);
8684     if ($CPAN::META->has_inst("File::Temp")) {
8685         $fh = File::Temp->new(
8686                               dir      => File::Spec->tmpdir,
8687                               template => "cpan_getsave_url_XXXX",
8688                               suffix => ".html",
8689                               unlink => 0,
8690                              );
8691         $filename = $fh->filename;
8692     } else {
8693         $fh = FileHandle->new;
8694         $filename = "cpan_getsave_url_$$.html";
8695     }
8696     my $tmpin = $filename;
8697     if ($CPAN::META->has_usable('LWP')) {
8698         $CPAN::Frontend->myprint("Fetching with LWP:
8699   $url
8700 ");
8701         my $Ua;
8702         CPAN::LWP::UserAgent->config;
8703         eval { $Ua = CPAN::LWP::UserAgent->new; };
8704         if ($@) {
8705             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8706             return;
8707         } else {
8708             my($var);
8709             $Ua->proxy('http', $var)
8710                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8711             $Ua->no_proxy($var)
8712                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8713         }
8714
8715         my $req = HTTP::Request->new(GET => $url);
8716         $req->header('Accept' => 'text/html');
8717         my $res = $Ua->request($req);
8718         if ($res->is_success) {
8719             $CPAN::Frontend->myprint(" + request successful.\n")
8720                 if $CPAN::DEBUG;
8721             print $fh $res->content;
8722             close $fh;
8723             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8724                 if $CPAN::DEBUG;
8725             return $tmpin;
8726         } else {
8727             $CPAN::Frontend->myprint(sprintf(
8728                                              "LWP failed with code[%s], message[%s]\n",
8729                                              $res->code,
8730                                              $res->message,
8731                                             ));
8732             return;
8733         }
8734     } else {
8735         $CPAN::Frontend->mywarn("  LWP not available\n");
8736         return;
8737     }
8738 }
8739
8740 # sub CPAN::Distribution::_build_command
8741 sub _build_command {
8742     my($self) = @_;
8743     if ($^O eq "MSWin32") { # special code needed at least up to
8744                             # Module::Build 0.2611 and 0.2706; a fix
8745                             # in M:B has been promised 2006-01-30
8746         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8747         return "$perl ./Build";
8748     }
8749     return "./Build";
8750 }
8751
8752 #-> sub CPAN::Distribution::reports
8753 sub reports {
8754     my($self) = @_;
8755     my $pathname = $self->id;
8756     $CPAN::Frontend->myprint("Distribution: $pathname\n");
8757
8758     unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
8759         $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
8760     }
8761     unless ($CPAN::META->has_usable("LWP")) {
8762         $CPAN::Frontend->mydie("LWP not installed; cannot continue");
8763     }
8764     unless ($CPAN::META->has_inst("File::Temp")) {
8765         $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
8766     }
8767
8768     my $d = CPAN::DistnameInfo->new($pathname);
8769
8770     my $dist      = $d->dist;      # "CPAN-DistnameInfo"
8771     my $version   = $d->version;   # "0.02"
8772     my $maturity  = $d->maturity;  # "released"
8773     my $filename  = $d->filename;  # "CPAN-DistnameInfo-0.02.tar.gz"
8774     my $cpanid    = $d->cpanid;    # "GBARR"
8775     my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
8776
8777     my $url = sprintf "http://cpantesters.perl.org/show/%s.yaml", $dist;
8778
8779     CPAN::LWP::UserAgent->config;
8780     my $Ua;
8781     eval { $Ua = CPAN::LWP::UserAgent->new; };
8782     if ($@) {
8783         $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
8784     }
8785     $CPAN::Frontend->myprint("Fetching '$url'...");
8786     my $resp = $Ua->get($url);
8787     unless ($resp->is_success) {
8788         $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
8789     }
8790     $CPAN::Frontend->myprint("DONE\n\n");
8791     my $yaml = $resp->content;
8792     # was fuer ein Umweg!
8793     my $fh = File::Temp->new(
8794                              dir      => File::Spec->tmpdir,
8795                              template => 'cpan_reports_XXXX',
8796                              suffix => '.yaml',
8797                              unlink => 0,
8798                             );
8799     my $tfilename = $fh->filename;
8800     print $fh $yaml;
8801     close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
8802     my $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
8803     unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
8804     my %other_versions;
8805     my $this_version_seen;
8806     for my $rep (@$unserialized) {
8807         my $rversion = $rep->{version};
8808         if ($rversion eq $version){
8809             unless ($this_version_seen++) {
8810                 $CPAN::Frontend->myprint ("$rep->{version}:\n");
8811             }
8812             $CPAN::Frontend->myprint
8813                 (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
8814                          $rep->{archname} eq $Config::Config{archname}?"*":"",
8815                          $rep->{action}eq"PASS"?"+":$rep->{action}eq"FAIL"?"-":"",
8816                          $rep->{action},
8817                          $rep->{perl},
8818                          ucfirst $rep->{osname},
8819                          $rep->{osvers},
8820                          $rep->{archname},
8821                         ));
8822         } else {
8823             $other_versions{$rep->{version}}++;
8824         }
8825     }
8826     unless ($this_version_seen) {
8827         $CPAN::Frontend->myprint("No reports found for version '$version'
8828 Reports for other versions:\n");
8829         for my $v (sort keys %other_versions) {
8830             $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
8831         }
8832     }
8833     $url =~ s/\.yaml/.html/;
8834     $CPAN::Frontend->myprint("See $url for details\n");
8835 }
8836
8837 package CPAN::Bundle;
8838 use strict;
8839
8840 sub look {
8841     my $self = shift;
8842     $CPAN::Frontend->myprint($self->as_string);
8843 }
8844
8845 #-> CPAN::Bundle::undelay
8846 sub undelay {
8847     my $self = shift;
8848     delete $self->{later};
8849     for my $c ( $self->contains ) {
8850         my $obj = CPAN::Shell->expandany($c) or next;
8851         $obj->undelay;
8852     }
8853 }
8854
8855 # mark as dirty/clean
8856 #-> sub CPAN::Bundle::color_cmd_tmps ;
8857 sub color_cmd_tmps {
8858     my($self) = shift;
8859     my($depth) = shift || 0;
8860     my($color) = shift || 0;
8861     my($ancestors) = shift || [];
8862     # a module needs to recurse to its cpan_file, a distribution needs
8863     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8864
8865     return if exists $self->{incommandcolor}
8866         && $color==1
8867         && $self->{incommandcolor}==$color;
8868     if ($depth>=$CPAN::MAX_RECURSION){
8869         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8870     }
8871     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8872
8873     for my $c ( $self->contains ) {
8874         my $obj = CPAN::Shell->expandany($c) or next;
8875         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8876         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8877     }
8878     # never reached code?
8879     #if ($color==0) {
8880       #delete $self->{badtestcnt};
8881     #}
8882     $self->{incommandcolor} = $color;
8883 }
8884
8885 #-> sub CPAN::Bundle::as_string ;
8886 sub as_string {
8887     my($self) = @_;
8888     $self->contains;
8889     # following line must be "=", not "||=" because we have a moving target
8890     $self->{INST_VERSION} = $self->inst_version;
8891     return $self->SUPER::as_string;
8892 }
8893
8894 #-> sub CPAN::Bundle::contains ;
8895 sub contains {
8896     my($self) = @_;
8897     my($inst_file) = $self->inst_file || "";
8898     my($id) = $self->id;
8899     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8900     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8901         undef $inst_file;
8902     }
8903     unless ($inst_file) {
8904         # Try to get at it in the cpan directory
8905         $self->debug("no inst_file") if $CPAN::DEBUG;
8906         my $cpan_file;
8907         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8908               $cpan_file = $self->cpan_file;
8909         if ($cpan_file eq "N/A") {
8910             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8911   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8912         }
8913         my $dist = $CPAN::META->instance('CPAN::Distribution',
8914                                          $self->cpan_file);
8915         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8916         $dist->get;
8917         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8918         my($todir) = $CPAN::Config->{'cpan_home'};
8919         my(@me,$from,$to,$me);
8920         @me = split /::/, $self->id;
8921         $me[-1] .= ".pm";
8922         $me = File::Spec->catfile(@me);
8923         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8924         $to = File::Spec->catfile($todir,$me);
8925         File::Path::mkpath(File::Basename::dirname($to));
8926         File::Copy::copy($from, $to)
8927               or Carp::confess("Couldn't copy $from to $to: $!");
8928         $inst_file = $to;
8929     }
8930     my @result;
8931     my $fh = FileHandle->new;
8932     local $/ = "\n";
8933     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8934     my $in_cont = 0;
8935     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8936     while (<$fh>) {
8937         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8938             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8939         next unless $in_cont;
8940         next if /^=/;
8941         s/\#.*//;
8942         next if /^\s+$/;
8943         chomp;
8944         push @result, (split " ", $_, 2)[0];
8945     }
8946     close $fh;
8947     delete $self->{STATUS};
8948     $self->{CONTAINS} = \@result;
8949     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8950     unless (@result) {
8951         $CPAN::Frontend->mywarn(qq{
8952 The bundle file "$inst_file" may be a broken
8953 bundlefile. It seems not to contain any bundle definition.
8954 Please check the file and if it is bogus, please delete it.
8955 Sorry for the inconvenience.
8956 });
8957     }
8958     @result;
8959 }
8960
8961 #-> sub CPAN::Bundle::find_bundle_file
8962 # $where is in local format, $what is in unix format
8963 sub find_bundle_file {
8964     my($self,$where,$what) = @_;
8965     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8966 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8967 ###    my $bu = File::Spec->catfile($where,$what);
8968 ###    return $bu if -f $bu;
8969     my $manifest = File::Spec->catfile($where,"MANIFEST");
8970     unless (-f $manifest) {
8971         require ExtUtils::Manifest;
8972         my $cwd = CPAN::anycwd();
8973         $self->safe_chdir($where);
8974         ExtUtils::Manifest::mkmanifest();
8975         $self->safe_chdir($cwd);
8976     }
8977     my $fh = FileHandle->new($manifest)
8978         or Carp::croak("Couldn't open $manifest: $!");
8979     local($/) = "\n";
8980     my $bundle_filename = $what;
8981     $bundle_filename =~ s|Bundle.*/||;
8982     my $bundle_unixpath;
8983     while (<$fh>) {
8984         next if /^\s*\#/;
8985         my($file) = /(\S+)/;
8986         if ($file =~ m|\Q$what\E$|) {
8987             $bundle_unixpath = $file;
8988             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8989             last;
8990         }
8991         # retry if she managed to have no Bundle directory
8992         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8993     }
8994     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8995         if $bundle_unixpath;
8996     Carp::croak("Couldn't find a Bundle file in $where");
8997 }
8998
8999 # needs to work quite differently from Module::inst_file because of
9000 # cpan_home/Bundle/ directory and the possibility that we have
9001 # shadowing effect. As it makes no sense to take the first in @INC for
9002 # Bundles, we parse them all for $VERSION and take the newest.
9003
9004 #-> sub CPAN::Bundle::inst_file ;
9005 sub inst_file {
9006     my($self) = @_;
9007     my($inst_file);
9008     my(@me);
9009     @me = split /::/, $self->id;
9010     $me[-1] .= ".pm";
9011     my($incdir,$bestv);
9012     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
9013         my $bfile = File::Spec->catfile($incdir, @me);
9014         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
9015         next unless -f $bfile;
9016         my $foundv = MM->parse_version($bfile);
9017         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
9018             $self->{INST_FILE} = $bfile;
9019             $self->{INST_VERSION} = $bestv = $foundv;
9020         }
9021     }
9022     $self->{INST_FILE};
9023 }
9024
9025 #-> sub CPAN::Bundle::inst_version ;
9026 sub inst_version {
9027     my($self) = @_;
9028     $self->inst_file; # finds INST_VERSION as side effect
9029     $self->{INST_VERSION};
9030 }
9031
9032 #-> sub CPAN::Bundle::rematein ;
9033 sub rematein {
9034     my($self,$meth) = @_;
9035     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
9036     my($id) = $self->id;
9037     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
9038         unless $self->inst_file || $self->cpan_file;
9039     my($s,%fail);
9040     for $s ($self->contains) {
9041         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
9042             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
9043         if ($type eq 'CPAN::Distribution') {
9044             $CPAN::Frontend->mywarn(qq{
9045 The Bundle }.$self->id.qq{ contains
9046 explicitly a file '$s'.
9047 Going to $meth that.
9048 });
9049             $CPAN::Frontend->mysleep(5);
9050         }
9051         # possibly noisy action:
9052         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
9053         my $obj = $CPAN::META->instance($type,$s);
9054         $obj->{reqtype} = $self->{reqtype};
9055         $obj->$meth();
9056     }
9057 }
9058
9059 # If a bundle contains another that contains an xs_file we have here,
9060 # we just don't bother I suppose
9061 #-> sub CPAN::Bundle::xs_file
9062 sub xs_file {
9063     return 0;
9064 }
9065
9066 #-> sub CPAN::Bundle::force ;
9067 sub fforce   { shift->rematein('fforce',@_); }
9068 #-> sub CPAN::Bundle::force ;
9069 sub force   { shift->rematein('force',@_); }
9070 #-> sub CPAN::Bundle::notest ;
9071 sub notest  { shift->rematein('notest',@_); }
9072 #-> sub CPAN::Bundle::get ;
9073 sub get     { shift->rematein('get',@_); }
9074 #-> sub CPAN::Bundle::make ;
9075 sub make    { shift->rematein('make',@_); }
9076 #-> sub CPAN::Bundle::test ;
9077 sub test    {
9078     my $self = shift;
9079     # $self->{badtestcnt} ||= 0;
9080     $self->rematein('test',@_);
9081 }
9082 #-> sub CPAN::Bundle::install ;
9083 sub install {
9084   my $self = shift;
9085   $self->rematein('install',@_);
9086 }
9087 #-> sub CPAN::Bundle::clean ;
9088 sub clean   { shift->rematein('clean',@_); }
9089
9090 #-> sub CPAN::Bundle::uptodate ;
9091 sub uptodate {
9092     my($self) = @_;
9093     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
9094     my $c;
9095     foreach $c ($self->contains) {
9096         my $obj = CPAN::Shell->expandany($c);
9097         return 0 unless $obj->uptodate;
9098     }
9099     return 1;
9100 }
9101
9102 #-> sub CPAN::Bundle::readme ;
9103 sub readme  {
9104     my($self) = @_;
9105     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
9106 No File found for bundle } . $self->id . qq{\n}), return;
9107     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
9108     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
9109 }
9110
9111 package CPAN::Module;
9112 use strict;
9113
9114 # Accessors
9115 #-> sub CPAN::Module::userid
9116 sub userid {
9117     my $self = shift;
9118     my $ro = $self->ro;
9119     return unless $ro;
9120     return $ro->{userid} || $ro->{CPAN_USERID};
9121 }
9122 #-> sub CPAN::Module::description
9123 sub description {
9124     my $self = shift;
9125     my $ro = $self->ro or return "";
9126     $ro->{description}
9127 }
9128
9129 #-> sub CPAN::Module::distribution
9130 sub distribution {
9131     my($self) = @_;
9132     CPAN::Shell->expand("Distribution",$self->cpan_file);
9133 }
9134
9135 #-> sub CPAN::Module::undelay
9136 sub undelay {
9137     my $self = shift;
9138     delete $self->{later};
9139     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9140         $dist->undelay;
9141     }
9142 }
9143
9144 # mark as dirty/clean
9145 #-> sub CPAN::Module::color_cmd_tmps ;
9146 sub color_cmd_tmps {
9147     my($self) = shift;
9148     my($depth) = shift || 0;
9149     my($color) = shift || 0;
9150     my($ancestors) = shift || [];
9151     # a module needs to recurse to its cpan_file
9152
9153     return if exists $self->{incommandcolor}
9154         && $color==1
9155         && $self->{incommandcolor}==$color;
9156     return if $color==0 && !$self->{incommandcolor};
9157     if ($color>=1) {
9158         if ( $self->uptodate ) {
9159             $self->{incommandcolor} = $color;
9160             return;
9161         } elsif (my $have_version = $self->available_version) {
9162             # maybe what we have is good enough
9163             if (@$ancestors) {
9164                 my $who_asked_for_me = $ancestors->[-1];
9165                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9166                 if (0) {
9167                 } elsif ($obj->isa("CPAN::Bundle")) {
9168                     # bundles cannot specify a minimum version
9169                     return;
9170                 } elsif ($obj->isa("CPAN::Distribution")) {
9171                     if (my $prereq_pm = $obj->prereq_pm) {
9172                         for my $k (keys %$prereq_pm) {
9173                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9174                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9175                                     $self->{incommandcolor} = $color;
9176                                     return;
9177                                 }
9178                             }
9179                         }
9180                     }
9181                 }
9182             }
9183         }
9184     } else {
9185         $self->{incommandcolor} = $color; # set me before recursion,
9186                                           # so we can break it
9187     }
9188     if ($depth>=$CPAN::MAX_RECURSION){
9189         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9190     }
9191     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9192
9193     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9194         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9195     }
9196     # unreached code?
9197     # if ($color==0) {
9198     #    delete $self->{badtestcnt};
9199     # }
9200     $self->{incommandcolor} = $color;
9201 }
9202
9203 #-> sub CPAN::Module::as_glimpse ;
9204 sub as_glimpse {
9205     my($self) = @_;
9206     my(@m);
9207     my $class = ref($self);
9208     $class =~ s/^CPAN:://;
9209     my $color_on = "";
9210     my $color_off = "";
9211     if (
9212         $CPAN::Shell::COLOR_REGISTERED
9213         &&
9214         $CPAN::META->has_inst("Term::ANSIColor")
9215         &&
9216         $self->description
9217        ) {
9218         $color_on = Term::ANSIColor::color("green");
9219         $color_off = Term::ANSIColor::color("reset");
9220     }
9221     my $uptodateness = " ";
9222     if ($class eq "Bundle") {
9223     } elsif ($self->uptodate) {
9224         $uptodateness = "=";
9225     } elsif ($self->inst_version) {
9226         $uptodateness = "<";
9227     }
9228     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9229                      $class,
9230                      $uptodateness,
9231                      $color_on,
9232                      $self->id,
9233                      $color_off,
9234                      ($self->distribution ?
9235                       $self->distribution->pretty_id :
9236                       $self->cpan_userid
9237                      ),
9238                     );
9239     join "", @m;
9240 }
9241
9242 #-> sub CPAN::Module::dslip_status
9243 sub dslip_status {
9244     my($self) = @_;
9245     my($stat);
9246     # development status
9247     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9248                                               pre-alpha alpha beta released
9249                                               mature standard,;
9250     # support level
9251     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9252                                               developer comp.lang.perl.*
9253                                               none abandoned,;
9254     # language
9255     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9256     # interface
9257     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9258                                               references+ties
9259                                               object-oriented pragma
9260                                               hybrid none,;
9261     # public licence
9262     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9263                                               GPL LGPL
9264                                               BSD Artistic
9265                                               open-source
9266                                               distribution_allowed
9267                                               restricted_distribution
9268                                               no_licence,;
9269     for my $x (qw(d s l i p)) {
9270         $stat->{$x}{' '} = 'unknown';
9271         $stat->{$x}{'?'} = 'unknown';
9272     }
9273     my $ro = $self->ro;
9274     return +{} unless $ro && $ro->{statd};
9275     return {
9276             D  => $ro->{statd},
9277             S  => $ro->{stats},
9278             L  => $ro->{statl},
9279             I  => $ro->{stati},
9280             P  => $ro->{statp},
9281             DV => $stat->{D}{$ro->{statd}},
9282             SV => $stat->{S}{$ro->{stats}},
9283             LV => $stat->{L}{$ro->{statl}},
9284             IV => $stat->{I}{$ro->{stati}},
9285             PV => $stat->{P}{$ro->{statp}},
9286            };
9287 }
9288
9289 #-> sub CPAN::Module::as_string ;
9290 sub as_string {
9291     my($self) = @_;
9292     my(@m);
9293     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9294     my $class = ref($self);
9295     $class =~ s/^CPAN:://;
9296     local($^W) = 0;
9297     push @m, $class, " id = $self->{ID}\n";
9298     my $sprintf = "    %-12s %s\n";
9299     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9300         if $self->description;
9301     my $sprintf2 = "    %-12s %s (%s)\n";
9302     my($userid);
9303     $userid = $self->userid;
9304     if ( $userid ){
9305         my $author;
9306         if ($author = CPAN::Shell->expand('Author',$userid)) {
9307           my $email = "";
9308           my $m; # old perls
9309           if ($m = $author->email) {
9310             $email = " <$m>";
9311           }
9312           push @m, sprintf(
9313                            $sprintf2,
9314                            'CPAN_USERID',
9315                            $userid,
9316                            $author->fullname . $email
9317                           );
9318         }
9319     }
9320     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9321         if $self->cpan_version;
9322     if (my $cpan_file = $self->cpan_file){
9323         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9324         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9325             my $upload_date = $dist->upload_date;
9326             if ($upload_date) {
9327                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9328             }
9329         }
9330     }
9331     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9332     my $dslip = $self->dslip_status;
9333     push @m, sprintf(
9334                      $sprintf3,
9335                      'DSLIP_STATUS',
9336                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9337                     ) if $dslip->{D};
9338     my $local_file = $self->inst_file;
9339     unless ($self->{MANPAGE}) {
9340         my $manpage;
9341         if ($local_file) {
9342             $manpage = $self->manpage_headline($local_file);
9343         } else {
9344             # If we have already untarred it, we should look there
9345             my $dist = $CPAN::META->instance('CPAN::Distribution',
9346                                              $self->cpan_file);
9347             # warn "dist[$dist]";
9348             # mff=manifest file; mfh=manifest handle
9349             my($mff,$mfh);
9350             if (
9351                 $dist->{build_dir}
9352                 and
9353                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9354                 and
9355                 $mfh = FileHandle->new($mff)
9356                ) {
9357                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9358                 my $lfre = $self->id; # local file RE
9359                 $lfre =~ s/::/./g;
9360                 $lfre .= "\\.pm\$";
9361                 my($lfl); # local file file
9362                 local $/ = "\n";
9363                 my(@mflines) = <$mfh>;
9364                 for (@mflines) {
9365                     s/^\s+//;
9366                     s/\s.*//s;
9367                 }
9368                 while (length($lfre)>5 and !$lfl) {
9369                     ($lfl) = grep /$lfre/, @mflines;
9370                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9371                     $lfre =~ s/.+?\.//;
9372                 }
9373                 $lfl =~ s/\s.*//; # remove comments
9374                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9375                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9376                 # warn "lfl_abs[$lfl_abs]";
9377                 if (-f $lfl_abs) {
9378                     $manpage = $self->manpage_headline($lfl_abs);
9379                 }
9380             }
9381         }
9382         $self->{MANPAGE} = $manpage if $manpage;
9383     }
9384     my($item);
9385     for $item (qw/MANPAGE/) {
9386         push @m, sprintf($sprintf, $item, $self->{$item})
9387             if exists $self->{$item};
9388     }
9389     for $item (qw/CONTAINS/) {
9390         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9391             if exists $self->{$item} && @{$self->{$item}};
9392     }
9393     push @m, sprintf($sprintf, 'INST_FILE',
9394                      $local_file || "(not installed)");
9395     push @m, sprintf($sprintf, 'INST_VERSION',
9396                      $self->inst_version) if $local_file;
9397     join "", @m, "\n";
9398 }
9399
9400 #-> sub CPAN::Module::manpage_headline
9401 sub manpage_headline {
9402   my($self,$local_file) = @_;
9403   my(@local_file) = $local_file;
9404   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9405   push @local_file, $local_file;
9406   my(@result,$locf);
9407   for $locf (@local_file) {
9408     next unless -f $locf;
9409     my $fh = FileHandle->new($locf)
9410         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9411     my $inpod = 0;
9412     local $/ = "\n";
9413     while (<$fh>) {
9414       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9415           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9416       next unless $inpod;
9417       next if /^=/;
9418       next if /^\s+$/;
9419       chomp;
9420       push @result, $_;
9421     }
9422     close $fh;
9423     last if @result;
9424   }
9425   for (@result) {
9426       s/^\s+//;
9427       s/\s+$//;
9428   }
9429   join " ", @result;
9430 }
9431
9432 #-> sub CPAN::Module::cpan_file ;
9433 # Note: also inherited by CPAN::Bundle
9434 sub cpan_file {
9435     my $self = shift;
9436     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9437     unless ($self->ro) {
9438         CPAN::Index->reload;
9439     }
9440     my $ro = $self->ro;
9441     if ($ro && defined $ro->{CPAN_FILE}){
9442         return $ro->{CPAN_FILE};
9443     } else {
9444         my $userid = $self->userid;
9445         if ( $userid ) {
9446             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9447                 my $author = $CPAN::META->instance("CPAN::Author",
9448                                                    $userid);
9449                 my $fullname = $author->fullname;
9450                 my $email = $author->email;
9451                 unless (defined $fullname && defined $email) {
9452                     return sprintf("Contact Author %s",
9453                                    $userid,
9454                                   );
9455                 }
9456                 return "Contact Author $fullname <$email>";
9457             } else {
9458                 return "Contact Author $userid (Email address not available)";
9459             }
9460         } else {
9461             return "N/A";
9462         }
9463     }
9464 }
9465
9466 #-> sub CPAN::Module::cpan_version ;
9467 sub cpan_version {
9468     my $self = shift;
9469
9470     my $ro = $self->ro;
9471     unless ($ro) {
9472         # Can happen with modules that are not on CPAN
9473         $ro = {};
9474     }
9475     $ro->{CPAN_VERSION} = 'undef'
9476         unless defined $ro->{CPAN_VERSION};
9477     $ro->{CPAN_VERSION};
9478 }
9479
9480 #-> sub CPAN::Module::force ;
9481 sub force {
9482     my($self) = @_;
9483     $self->{force_update} = 1;
9484 }
9485
9486 #-> sub CPAN::Module::fforce ;
9487 sub fforce {
9488     my($self) = @_;
9489     $self->{force_update} = 2;
9490 }
9491
9492 #-> sub CPAN::Module::notest ;
9493 sub notest {
9494     my($self) = @_;
9495     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
9496     $self->{notest}++;
9497 }
9498
9499 #-> sub CPAN::Module::rematein ;
9500 sub rematein {
9501     my($self,$meth) = @_;
9502     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9503                                      $meth,
9504                                      $self->id));
9505     my $cpan_file = $self->cpan_file;
9506     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9507       $CPAN::Frontend->mywarn(sprintf qq{
9508   The module %s isn\'t available on CPAN.
9509
9510   Either the module has not yet been uploaded to CPAN, or it is
9511   temporary unavailable. Please contact the author to find out
9512   more about the status. Try 'i %s'.
9513 },
9514                               $self->id,
9515                               $self->id,
9516                              );
9517       return;
9518     }
9519     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9520     $pack->called_for($self->id);
9521     if (exists $self->{force_update}){
9522         if ($self->{force_update} == 2) {
9523             $pack->fforce($meth);
9524         } else {
9525             $pack->force($meth);
9526         }
9527     }
9528     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
9529
9530     $pack->{reqtype} ||= "";
9531     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9532                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9533         if ($pack->{reqtype}) {
9534             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9535                 $pack->{reqtype} = $self->{reqtype};
9536                 if (
9537                     exists $pack->{install}
9538                     &&
9539                     (
9540                      UNIVERSAL::can($pack->{install},"failed") ?
9541                      $pack->{install}->failed :
9542                      $pack->{install} =~ /^NO/
9543                     )
9544                    ) {
9545                     delete $pack->{install};
9546                     $CPAN::Frontend->mywarn
9547                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9548                 }
9549             }
9550         } else {
9551             $pack->{reqtype} = $self->{reqtype};
9552         }
9553
9554     my $success = eval {
9555         $pack->$meth();
9556     };
9557     my $err = $@;
9558     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9559     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
9560     delete $self->{force_update};
9561     delete $self->{notest};
9562     if ($err) {
9563         die $err;
9564     }
9565     return $success;
9566 }
9567
9568 #-> sub CPAN::Module::perldoc ;
9569 sub perldoc { shift->rematein('perldoc') }
9570 #-> sub CPAN::Module::readme ;
9571 sub readme  { shift->rematein('readme') }
9572 #-> sub CPAN::Module::look ;
9573 sub look    { shift->rematein('look') }
9574 #-> sub CPAN::Module::cvs_import ;
9575 sub cvs_import { shift->rematein('cvs_import') }
9576 #-> sub CPAN::Module::get ;
9577 sub get     { shift->rematein('get',@_) }
9578 #-> sub CPAN::Module::make ;
9579 sub make    { shift->rematein('make') }
9580 #-> sub CPAN::Module::test ;
9581 sub test   {
9582     my $self = shift;
9583     # $self->{badtestcnt} ||= 0;
9584     $self->rematein('test',@_);
9585 }
9586 #-> sub CPAN::Module::uptodate ;
9587 sub uptodate {
9588     my($self) = @_;
9589     local($_); # protect against a bug in MakeMaker 6.17
9590     my($latest) = $self->cpan_version;
9591     $latest ||= 0;
9592     my($inst_file) = $self->inst_file;
9593     my($have) = 0;
9594     if (defined $inst_file) {
9595         $have = $self->inst_version;
9596     }
9597     local($^W)=0;
9598     if ($inst_file
9599         &&
9600         ! CPAN::Version->vgt($latest, $have)
9601        ) {
9602         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9603                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9604         return 1;
9605     }
9606     return;
9607 }
9608 #-> sub CPAN::Module::install ;
9609 sub install {
9610     my($self) = @_;
9611     my($doit) = 0;
9612     if ($self->uptodate
9613         &&
9614         not exists $self->{force_update}
9615        ) {
9616         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9617                                          $self->id,
9618                                          $self->inst_version,
9619                                         ));
9620     } else {
9621         $doit = 1;
9622     }
9623     my $ro = $self->ro;
9624     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9625         $CPAN::Frontend->mywarn(qq{
9626 \n\n\n     ***WARNING***
9627      The module $self->{ID} has no active maintainer.\n\n\n
9628 });
9629         $CPAN::Frontend->mysleep(5);
9630     }
9631     $self->rematein('install') if $doit;
9632 }
9633 #-> sub CPAN::Module::clean ;
9634 sub clean  { shift->rematein('clean') }
9635
9636 #-> sub CPAN::Module::inst_file ;
9637 sub inst_file {
9638     my($self) = @_;
9639     $self->_file_in_path([@INC]);
9640 }
9641
9642 #-> sub CPAN::Module::available_file ;
9643 sub available_file {
9644     my($self) = @_;
9645     my $sep = $Config::Config{path_sep};
9646     my $perllib = $ENV{PERL5LIB};
9647     $perllib = $ENV{PERLLIB} unless defined $perllib;
9648     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9649     $self->_file_in_path([@perllib,@INC]);
9650 }
9651
9652 #-> sub CPAN::Module::file_in_path ;
9653 sub _file_in_path {
9654     my($self,$path) = @_;
9655     my($dir,@packpath);
9656     @packpath = split /::/, $self->{ID};
9657     $packpath[-1] .= ".pm";
9658     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9659         unshift @packpath, "Term", "ReadLine"; # historical reasons
9660     }
9661     foreach $dir (@$path) {
9662         my $pmfile = File::Spec->catfile($dir,@packpath);
9663         if (-f $pmfile){
9664             return $pmfile;
9665         }
9666     }
9667     return;
9668 }
9669
9670 #-> sub CPAN::Module::xs_file ;
9671 sub xs_file {
9672     my($self) = @_;
9673     my($dir,@packpath);
9674     @packpath = split /::/, $self->{ID};
9675     push @packpath, $packpath[-1];
9676     $packpath[-1] .= "." . $Config::Config{'dlext'};
9677     foreach $dir (@INC) {
9678         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9679         if (-f $xsfile){
9680             return $xsfile;
9681         }
9682     }
9683     return;
9684 }
9685
9686 #-> sub CPAN::Module::inst_version ;
9687 sub inst_version {
9688     my($self) = @_;
9689     my $parsefile = $self->inst_file or return;
9690     my $have = $self->parse_version($parsefile);
9691     $have;
9692 }
9693
9694 #-> sub CPAN::Module::inst_version ;
9695 sub available_version {
9696     my($self) = @_;
9697     my $parsefile = $self->available_file or return;
9698     my $have = $self->parse_version($parsefile);
9699     $have;
9700 }
9701
9702 #-> sub CPAN::Module::parse_version ;
9703 sub parse_version {
9704     my($self,$parsefile) = @_;
9705     my $have = MM->parse_version($parsefile);
9706     $have = "undef" unless defined $have && length $have;
9707     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9708     $have =~ s/ $//; # trailing whitespace happens all the time
9709
9710     $have = CPAN::Version->readable($have);
9711
9712     $have =~ s/\s*//g; # stringify to float around floating point issues
9713     $have; # no stringify needed, \s* above matches always
9714 }
9715
9716 #-> sub CPAN::Module::reports
9717 sub reports {
9718     my($self) = @_;
9719     $self->distribution->reports;
9720 }
9721
9722 package CPAN;
9723 use strict;
9724
9725 1;
9726
9727
9728 __END__
9729
9730 =head1 NAME
9731
9732 CPAN - query, download and build perl modules from CPAN sites
9733
9734 =head1 SYNOPSIS
9735
9736 Interactive mode:
9737
9738   perl -MCPAN -e shell
9739
9740 --or--
9741
9742   cpan
9743
9744 Basic commands:
9745
9746   # Modules:
9747
9748   cpan> install Acme::Meta                       # in the shell
9749
9750   CPAN::Shell->install("Acme::Meta");            # in perl
9751
9752   # Distributions:
9753
9754   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9755
9756   CPAN::Shell->
9757     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9758
9759   # module objects:
9760
9761   $mo = CPAN::Shell->expandany($mod);
9762   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9763
9764   # distribution objects:
9765
9766   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9767   $do = CPAN::Shell->expandany($distro);         # same thing
9768   $do = CPAN::Shell->expand("Distribution",
9769                             $distro);            # same thing
9770
9771 =head1 DESCRIPTION
9772
9773 The CPAN module automates or at least simplifies the make and install
9774 of perl modules and extensions. It includes some primitive searching
9775 capabilities and knows how to use Net::FTP or LWP or some external
9776 download clients to fetch the distributions from the net.
9777
9778 These are fetched from one or more of the mirrored CPAN (Comprehensive
9779 Perl Archive Network) sites and unpacked in a dedicated directory.
9780
9781 The CPAN module also supports the concept of named and versioned
9782 I<bundles> of modules. Bundles simplify the handling of sets of
9783 related modules. See Bundles below.
9784
9785 The package contains a session manager and a cache manager. The
9786 session manager keeps track of what has been fetched, built and
9787 installed in the current session. The cache manager keeps track of the
9788 disk space occupied by the make processes and deletes excess space
9789 according to a simple FIFO mechanism.
9790
9791 All methods provided are accessible in a programmer style and in an
9792 interactive shell style.
9793
9794 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9795
9796 The interactive mode is entered by running
9797
9798     perl -MCPAN -e shell
9799
9800 or
9801
9802     cpan
9803
9804 which puts you into a readline interface. If C<Term::ReadKey> and
9805 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9806 it supports both history and command completion.
9807
9808 Once you are on the command line, type C<h> to get a one page help
9809 screen and the rest should be self-explanatory.
9810
9811 The function call C<shell> takes two optional arguments, one is the
9812 prompt, the second is the default initial command line (the latter
9813 only works if a real ReadLine interface module is installed).
9814
9815 The most common uses of the interactive modes are
9816
9817 =over 2
9818
9819 =item Searching for authors, bundles, distribution files and modules
9820
9821 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9822 for each of the four categories and another, C<i> for any of the
9823 mentioned four. Each of the four entities is implemented as a class
9824 with slightly differing methods for displaying an object.
9825
9826 Arguments you pass to these commands are either strings exactly matching
9827 the identification string of an object or regular expressions that are
9828 then matched case-insensitively against various attributes of the
9829 objects. The parser recognizes a regular expression only if you
9830 enclose it between two slashes.
9831
9832 The principle is that the number of found objects influences how an
9833 item is displayed. If the search finds one item, the result is
9834 displayed with the rather verbose method C<as_string>, but if we find
9835 more than one, we display each object with the terse method
9836 C<as_glimpse>.
9837
9838 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9839
9840 These commands take any number of arguments and investigate what is
9841 necessary to perform the action. If the argument is a distribution
9842 file name (recognized by embedded slashes), it is processed. If it is
9843 a module, CPAN determines the distribution file in which this module
9844 is included and processes that, following any dependencies named in
9845 the module's META.yml or Makefile.PL (this behavior is controlled by
9846 the configuration parameter C<prerequisites_policy>.)
9847
9848 C<get> downloads a distribution file and untars or unzips it, C<make>
9849 builds it, C<test> runs the test suite, and C<install> installs it.
9850
9851 Any C<make> or C<test> are run unconditionally. An
9852
9853   install <distribution_file>
9854
9855 also is run unconditionally. But for
9856
9857   install <module>
9858
9859 CPAN checks if an install is actually needed for it and prints
9860 I<module up to date> in the case that the distribution file containing
9861 the module doesn't need to be updated.
9862
9863 CPAN also keeps track of what it has done within the current session
9864 and doesn't try to build a package a second time regardless if it
9865 succeeded or not. It does not repeat a test run if the test
9866 has been run successfully before. Same for install runs.
9867
9868 The C<force> pragma may precede another command (currently: C<get>,
9869 C<make>, C<test>, or C<install>) and executes the command from scratch
9870 and tries to continue in case of some errors. See the section below on
9871 the C<force> and the C<fforce> pragma.
9872
9873 The C<notest> pragma may be used to skip the test part in the build
9874 process.
9875
9876 Example:
9877
9878     cpan> notest install Tk
9879
9880 A C<clean> command results in a
9881
9882   make clean
9883
9884 being executed within the distribution file's working directory.
9885
9886 =item C<readme>, C<perldoc>, C<look> module or distribution
9887
9888 C<readme> displays the README file of the associated distribution.
9889 C<Look> gets and untars (if not yet done) the distribution file,
9890 changes to the appropriate directory and opens a subshell process in
9891 that directory. C<perldoc> displays the pod documentation of the
9892 module in html or plain text format.
9893
9894 =item C<ls> author
9895
9896 =item C<ls> globbing_expression
9897
9898 The first form lists all distribution files in and below an author's
9899 CPAN directory as they are stored in the CHECKUMS files distributed on
9900 CPAN. The listing goes recursive into all subdirectories.
9901
9902 The second form allows to limit or expand the output with shell
9903 globbing as in the following examples:
9904
9905           ls JV/make*
9906           ls GSAR/*make*
9907           ls */*make*
9908
9909 The last example is very slow and outputs extra progress indicators
9910 that break the alignment of the result.
9911
9912 Note that globbing only lists directories explicitly asked for, for
9913 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9914 regarded as a bug and may be changed in future versions.
9915
9916 =item C<failed>
9917
9918 The C<failed> command reports all distributions that failed on one of
9919 C<make>, C<test> or C<install> for some reason in the currently
9920 running shell session.
9921
9922 =item Persistence between sessions
9923
9924 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9925 the internal state of all modules is written to disk after each step.
9926 The files contain a signature of the currently running perl version
9927 for later perusal.
9928
9929 If the configurations variable C<build_dir_reuse> is set to a true
9930 value, then CPAN.pm reads the collected YAML files. If the stored
9931 signature matches the currently running perl the stored state is
9932 loaded into memory such that effectively persistence between sessions
9933 is established.
9934
9935 =item The C<force> and the C<fforce> pragma
9936
9937 To speed things up in complex installation scenarios, CPAN.pm keeps
9938 track of what it has already done and refuses to do some things a
9939 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9940 A C<test> is only repeated if the previous test was unsuccessful. The
9941 diagnostic message when CPAN.pm refuses to do something a second time
9942 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9943 something similar. Another situation where CPAN refuses to act is an
9944 C<install> if the according C<test> was not successful.
9945
9946 In all these cases, the user can override the goatish behaviour by
9947 prepending the command with the word force, for example:
9948
9949   cpan> force get Foo
9950   cpan> force make AUTHOR/Bar-3.14.tar.gz
9951   cpan> force test Baz
9952   cpan> force install Acme::Meta
9953
9954 Each I<forced> command is executed with the according part of its
9955 memory erased.
9956
9957 The C<fforce> pragma is a variant that emulates a C<force get> which
9958 erases the entire memory followed by the action specified, effectively
9959 restarting the whole get/make/test/install procedure from scratch.
9960
9961 =item Lockfile
9962
9963 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9964 Batch jobs can run without a lockfile and do not disturb each other.
9965
9966 The shell offers to run in I<degraded mode> when another process is
9967 holding the lockfile. This is an experimental feature that is not yet
9968 tested very well. This second shell then does not write the history
9969 file, does not use the metadata file and has a different prompt.
9970
9971 =item Signals
9972
9973 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9974 in the cpan-shell it is intended that you can press C<^C> anytime and
9975 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9976 to clean up and leave the shell loop. You can emulate the effect of a
9977 SIGTERM by sending two consecutive SIGINTs, which usually means by
9978 pressing C<^C> twice.
9979
9980 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9981 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9982 Build.PL> subprocess.
9983
9984 =back
9985
9986 =head2 CPAN::Shell
9987
9988 The commands that are available in the shell interface are methods in
9989 the package CPAN::Shell. If you enter the shell command, all your
9990 input is split by the Text::ParseWords::shellwords() routine which
9991 acts like most shells do. The first word is being interpreted as the
9992 method to be called and the rest of the words are treated as arguments
9993 to this method. Continuation lines are supported if a line ends with a
9994 literal backslash.
9995
9996 =head2 autobundle
9997
9998 C<autobundle> writes a bundle file into the
9999 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
10000 a list of all modules that are both available from CPAN and currently
10001 installed within @INC. The name of the bundle file is based on the
10002 current date and a counter.
10003
10004 =head2 hosts
10005
10006 Note: this feature is still in alpha state and may change in future
10007 versions of CPAN.pm
10008
10009 This commands provides a statistical overview over recent download
10010 activities. The data for this is collected in the YAML file
10011 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
10012 configured or YAML not installed, then no stats are provided.
10013
10014 =head2 mkmyconfig
10015
10016 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
10017 directory so that you can save your own preferences instead of the
10018 system wide ones.
10019
10020 =head2 recompile
10021
10022 recompile() is a very special command in that it takes no argument and
10023 runs the make/test/install cycle with brute force over all installed
10024 dynamically loadable extensions (aka XS modules) with 'force' in
10025 effect. The primary purpose of this command is to finish a network
10026 installation. Imagine, you have a common source tree for two different
10027 architectures. You decide to do a completely independent fresh
10028 installation. You start on one architecture with the help of a Bundle
10029 file produced earlier. CPAN installs the whole Bundle for you, but
10030 when you try to repeat the job on the second architecture, CPAN
10031 responds with a C<"Foo up to date"> message for all modules. So you
10032 invoke CPAN's recompile on the second architecture and you're done.
10033
10034 Another popular use for C<recompile> is to act as a rescue in case your
10035 perl breaks binary compatibility. If one of the modules that CPAN uses
10036 is in turn depending on binary compatibility (so you cannot run CPAN
10037 commands), then you should try the CPAN::Nox module for recovery.
10038
10039 =head2 report Bundle|Distribution|Module
10040
10041 The C<report> command temporarily turns on the C<test_report> config
10042 variable, then runs the C<force test> command with the given
10043 arguments. The C<force> pragma is used to re-run the tests and repeat
10044 every step that might have failed before.
10045
10046 =head2 upgrade [Module|/Regex/]...
10047
10048 The C<upgrade> command first runs an C<r> command with the given
10049 arguments and then installs the newest versions of all modules that
10050 were listed by that.
10051
10052 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
10053
10054 Although it may be considered internal, the class hierarchy does matter
10055 for both users and programmer. CPAN.pm deals with above mentioned four
10056 classes, and all those classes share a set of methods. A classical
10057 single polymorphism is in effect. A metaclass object registers all
10058 objects of all kinds and indexes them with a string. The strings
10059 referencing objects have a separated namespace (well, not completely
10060 separated):
10061
10062          Namespace                         Class
10063
10064    words containing a "/" (slash)      Distribution
10065     words starting with Bundle::          Bundle
10066           everything else            Module or Author
10067
10068 Modules know their associated Distribution objects. They always refer
10069 to the most recent official release. Developers may mark their releases
10070 as unstable development versions (by inserting an underbar into the
10071 module version number which will also be reflected in the distribution
10072 name when you run 'make dist'), so the really hottest and newest
10073 distribution is not always the default.  If a module Foo circulates
10074 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
10075 way to install version 1.23 by saying
10076
10077     install Foo
10078
10079 This would install the complete distribution file (say
10080 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
10081 like to install version 1.23_90, you need to know where the
10082 distribution file resides on CPAN relative to the authors/id/
10083 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
10084 so you would have to say
10085
10086     install BAR/Foo-1.23_90.tar.gz
10087
10088 The first example will be driven by an object of the class
10089 CPAN::Module, the second by an object of class CPAN::Distribution.
10090
10091 =head2 Integrating local directories
10092
10093 Note: this feature is still in alpha state and may change in future
10094 versions of CPAN.pm
10095
10096 Distribution objects are normally distributions from the CPAN, but
10097 there is a slightly degenerate case for Distribution objects, too, of
10098 projects held on the local disk. These distribution objects have the
10099 same name as the local directory and end with a dot. A dot by itself
10100 is also allowed for the current directory at the time CPAN.pm was
10101 used. All actions such as C<make>, C<test>, and C<install> are applied
10102 directly to that directory. This gives the command C<cpan .> an
10103 interesting touch: while the normal mantra of installing a CPAN module
10104 without CPAN.pm is one of
10105
10106     perl Makefile.PL                 perl Build.PL
10107            ( go and get prerequisites )
10108     make                             ./Build
10109     make test                        ./Build test
10110     make install                     ./Build install
10111
10112 the command C<cpan .> does all of this at once. It figures out which
10113 of the two mantras is appropriate, fetches and installs all
10114 prerequisites, cares for them recursively and finally finishes the
10115 installation of the module in the current directory, be it a CPAN
10116 module or not.
10117
10118 The typical usage case is for private modules or working copies of
10119 projects from remote repositories on the local disk.
10120
10121 =head1 CONFIGURATION
10122
10123 When the CPAN module is used for the first time, a configuration
10124 dialog tries to determine a couple of site specific options. The
10125 result of the dialog is stored in a hash reference C< $CPAN::Config >
10126 in a file CPAN/Config.pm.
10127
10128 The default values defined in the CPAN/Config.pm file can be
10129 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
10130 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
10131 added to the search path of the CPAN module before the use() or
10132 require() statements. The mkmyconfig command writes this file for you.
10133
10134 The C<o conf> command has various bells and whistles:
10135
10136 =over
10137
10138 =item completion support
10139
10140 If you have a ReadLine module installed, you can hit TAB at any point
10141 of the commandline and C<o conf> will offer you completion for the
10142 built-in subcommands and/or config variable names.
10143
10144 =item displaying some help: o conf help
10145
10146 Displays a short help
10147
10148 =item displaying current values: o conf [KEY]
10149
10150 Displays the current value(s) for this config variable. Without KEY
10151 displays all subcommands and config variables.
10152
10153 Example:
10154
10155   o conf shell
10156
10157 =item changing of scalar values: o conf KEY VALUE
10158
10159 Sets the config variable KEY to VALUE. The empty string can be
10160 specified as usual in shells, with C<''> or C<"">
10161
10162 Example:
10163
10164   o conf wget /usr/bin/wget
10165
10166 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10167
10168 If a config variable name ends with C<list>, it is a list. C<o conf
10169 KEY shift> removes the first element of the list, C<o conf KEY pop>
10170 removes the last element of the list. C<o conf KEYS unshift LIST>
10171 prepends a list of values to the list, C<o conf KEYS push LIST>
10172 appends a list of valued to the list.
10173
10174 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10175 splice command.
10176
10177 Finally, any other list of arguments is taken as a new list value for
10178 the KEY variable discarding the previous value.
10179
10180 Examples:
10181
10182   o conf urllist unshift http://cpan.dev.local/CPAN
10183   o conf urllist splice 3 1
10184   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10185
10186 =item reverting to saved: o conf defaults
10187
10188 Reverts all config variables to the state in the saved config file.
10189
10190 =item saving the config: o conf commit
10191
10192 Saves all config variables to the current config file (CPAN/Config.pm
10193 or CPAN/MyConfig.pm that was loaded at start).
10194
10195 =back
10196
10197 The configuration dialog can be started any time later again by
10198 issuing the command C< o conf init > in the CPAN shell. A subset of
10199 the configuration dialog can be run by issuing C<o conf init WORD>
10200 where WORD is any valid config variable or a regular expression.
10201
10202 =head2 Config Variables
10203
10204 Currently the following keys in the hash reference $CPAN::Config are
10205 defined:
10206
10207   applypatch         path to external prg
10208   auto_commit        commit all changes to config variables to disk
10209   build_cache        size of cache for directories to build modules
10210   build_dir          locally accessible directory to build modules
10211   build_dir_reuse    boolean if distros in build_dir are persistent
10212   build_requires_install_policy
10213                      to install or not to install when a module is
10214                      only needed for building. yes|no|ask/yes|ask/no
10215   bzip2              path to external prg
10216   cache_metadata     use serializer to cache metadata
10217   commands_quote     prefered character to use for quoting external
10218                      commands when running them. Defaults to double
10219                      quote on Windows, single tick everywhere else;
10220                      can be set to space to disable quoting
10221   check_sigs         if signatures should be verified
10222   colorize_debug     Term::ANSIColor attributes for debugging output
10223   colorize_output    boolean if Term::ANSIColor should colorize output
10224   colorize_print     Term::ANSIColor attributes for normal output
10225   colorize_warn      Term::ANSIColor attributes for warnings
10226   commandnumber_in_prompt
10227                      boolean if you want to see current command number
10228   cpan_home          local directory reserved for this package
10229   curl               path to external prg
10230   dontload_hash      DEPRECATED
10231   dontload_list      arrayref: modules in the list will not be
10232                      loaded by the CPAN::has_inst() routine
10233   ftp                path to external prg
10234   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10235   ftp_proxy          proxy host for ftp requests
10236   getcwd             see below
10237   gpg                path to external prg
10238   gzip               location of external program gzip
10239   histfile           file to maintain history between sessions
10240   histsize           maximum number of lines to keep in histfile
10241   http_proxy         proxy host for http requests
10242   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10243                      after this many seconds inactivity. Set to 0 to
10244                      never break.
10245   index_expire       after this many days refetch index files
10246   inhibit_startup_message
10247                      if true, does not print the startup message
10248   keep_source_where  directory in which to keep the source (if we do)
10249   lynx               path to external prg
10250   make               location of external make program
10251   make_arg           arguments that should always be passed to 'make'
10252   make_install_make_command
10253                      the make command for running 'make install', for
10254                      example 'sudo make'
10255   make_install_arg   same as make_arg for 'make install'
10256   makepl_arg         arguments passed to 'perl Makefile.PL'
10257   mbuild_arg         arguments passed to './Build'
10258   mbuild_install_arg arguments passed to './Build install'
10259   mbuild_install_build_command
10260                      command to use instead of './Build' when we are
10261                      in the install stage, for example 'sudo ./Build'
10262   mbuildpl_arg       arguments passed to 'perl Build.PL'
10263   ncftp              path to external prg
10264   ncftpget           path to external prg
10265   no_proxy           don't proxy to these hosts/domains (comma separated list)
10266   pager              location of external program more (or any pager)
10267   password           your password if you CPAN server wants one
10268   patch              path to external prg
10269   prefer_installer   legal values are MB and EUMM: if a module comes
10270                      with both a Makefile.PL and a Build.PL, use the
10271                      former (EUMM) or the latter (MB); if the module
10272                      comes with only one of the two, that one will be
10273                      used in any case
10274   prerequisites_policy
10275                      what to do if you are missing module prerequisites
10276                      ('follow' automatically, 'ask' me, or 'ignore')
10277   prefs_dir          local directory to store per-distro build options
10278   proxy_user         username for accessing an authenticating proxy
10279   proxy_pass         password for accessing an authenticating proxy
10280   randomize_urllist  add some randomness to the sequence of the urllist
10281   scan_cache         controls scanning of cache ('atstart' or 'never')
10282   shell              your favorite shell
10283   show_upload_date   boolean if commands should try to determine upload date
10284   tar                location of external program tar
10285   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10286                      (and nonsense for characters outside latin range)
10287   term_ornaments     boolean to turn ReadLine ornamenting on/off
10288   test_report        email test reports (if CPAN::Reporter is installed)
10289   unzip              location of external program unzip
10290   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10291   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10292   username           your username if you CPAN server wants one
10293   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10294   wget               path to external prg
10295   yaml_module        which module to use to read/write YAML files
10296
10297 You can set and query each of these options interactively in the cpan
10298 shell with the C<o conf> or the C<o conf init> command as specified below.
10299
10300 =over 2
10301
10302 =item C<o conf E<lt>scalar optionE<gt>>
10303
10304 prints the current value of the I<scalar option>
10305
10306 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10307
10308 Sets the value of the I<scalar option> to I<value>
10309
10310 =item C<o conf E<lt>list optionE<gt>>
10311
10312 prints the current value of the I<list option> in MakeMaker's
10313 neatvalue format.
10314
10315 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10316
10317 shifts or pops the array in the I<list option> variable
10318
10319 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10320
10321 works like the corresponding perl commands.
10322
10323 =item interactive editing: o conf init [MATCH|LIST]
10324
10325 Runs an interactive configuration dialog for matching variables.
10326 Without argument runs the dialog over all supported config variables.
10327 To specify a MATCH the argument must be enclosed by slashes.
10328
10329 Examples:
10330
10331   o conf init ftp_passive ftp_proxy
10332   o conf init /color/
10333
10334 Note: this method of setting config variables often provides more
10335 explanation about the functioning of a variable than the manpage.
10336
10337 =back
10338
10339 =head2 CPAN::anycwd($path): Note on config variable getcwd
10340
10341 CPAN.pm changes the current working directory often and needs to
10342 determine its own current working directory. Per default it uses
10343 Cwd::cwd but if this doesn't work on your system for some reason,
10344 alternatives can be configured according to the following table:
10345
10346 =over 4
10347
10348 =item cwd
10349
10350 Calls Cwd::cwd
10351
10352 =item getcwd
10353
10354 Calls Cwd::getcwd
10355
10356 =item fastcwd
10357
10358 Calls Cwd::fastcwd
10359
10360 =item backtickcwd
10361
10362 Calls the external command cwd.
10363
10364 =back
10365
10366 =head2 Note on the format of the urllist parameter
10367
10368 urllist parameters are URLs according to RFC 1738. We do a little
10369 guessing if your URL is not compliant, but if you have problems with
10370 C<file> URLs, please try the correct format. Either:
10371
10372     file://localhost/whatever/ftp/pub/CPAN/
10373
10374 or
10375
10376     file:///home/ftp/pub/CPAN/
10377
10378 =head2 The urllist parameter has CD-ROM support
10379
10380 The C<urllist> parameter of the configuration table contains a list of
10381 URLs that are to be used for downloading. If the list contains any
10382 C<file> URLs, CPAN always tries to get files from there first. This
10383 feature is disabled for index files. So the recommendation for the
10384 owner of a CD-ROM with CPAN contents is: include your local, possibly
10385 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10386
10387   o conf urllist push file://localhost/CDROM/CPAN
10388
10389 CPAN.pm will then fetch the index files from one of the CPAN sites
10390 that come at the beginning of urllist. It will later check for each
10391 module if there is a local copy of the most recent version.
10392
10393 Another peculiarity of urllist is that the site that we could
10394 successfully fetch the last file from automatically gets a preference
10395 token and is tried as the first site for the next request. So if you
10396 add a new site at runtime it may happen that the previously preferred
10397 site will be tried another time. This means that if you want to disallow
10398 a site for the next transfer, it must be explicitly removed from
10399 urllist.
10400
10401 =head2 Maintaining the urllist parameter
10402
10403 If you have YAML.pm (or some other YAML module configured in
10404 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10405 about recent downloads. You can view the statistics with the C<hosts>
10406 command or inspect them directly by looking into the C<FTPstats.yml>
10407 file in your C<cpan_home> directory.
10408
10409 To get some interesting statistics it is recommended to set the
10410 C<randomize_urllist> parameter that introduces some amount of
10411 randomness into the URL selection.
10412
10413 =head2 The C<requires> and C<build_requires> dependency declarations
10414
10415 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10416 a distribution are treated differently depending on the config
10417 variable C<build_requires_install_policy>. By setting
10418 C<build_requires_install_policy> to C<no> such a module is not being
10419 installed. It is only built and tested and then kept in the list of
10420 tested but uninstalled modules. As such it is available during the
10421 build of the dependent module by integrating the path to the
10422 C<blib/arch> and C<blib/lib> directories in the environment variable
10423 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10424 both modules declared as C<requires> and those declared as
10425 C<build_requires> are treated alike. By setting to C<ask/yes> or
10426 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10427
10428 =head2 Configuration for individual distributions (I<Distroprefs>)
10429
10430 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10431 still considered beta quality)
10432
10433 Distributions on the CPAN usually behave according to what we call the
10434 CPAN mantra. Or since the event of Module::Build we should talk about
10435 two mantras:
10436
10437     perl Makefile.PL     perl Build.PL
10438     make                 ./Build
10439     make test            ./Build test
10440     make install         ./Build install
10441
10442 But some modules cannot be built with this mantra. They try to get
10443 some extra data from the user via the environment, extra arguments or
10444 interactively thus disturbing the installation of large bundles like
10445 Phalanx100 or modules with many dependencies like Plagger.
10446
10447 The distroprefs system of C<CPAN.pm> addresses this problem by
10448 allowing the user to specify extra informations and recipes in YAML
10449 files to either
10450
10451 =over
10452
10453 =item
10454
10455 pass additional arguments to one of the four commands,
10456
10457 =item
10458
10459 set environment variables
10460
10461 =item
10462
10463 instantiate an Expect object that reads from the console, waits for
10464 some regular expressions and enters some answers
10465
10466 =item
10467
10468 temporarily override assorted C<CPAN.pm> configuration variables
10469
10470 =item
10471
10472 disable the installation of an object altogether
10473
10474 =back
10475
10476 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10477 distribution in the C<distroprefs/> directory for examples.
10478
10479 =head2 Filenames
10480
10481 The YAML files themselves must have the C<.yml> extension, all other
10482 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10483 Storable> below). The containing directory can be specified in
10484 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10485 prefs_dir> in the CPAN shell to set and activate the distroprefs
10486 system.
10487
10488 Every YAML file may contain arbitrary documents according to the YAML
10489 specification and every single document is treated as an entity that
10490 can specify the treatment of a single distribution.
10491
10492 The names of the files can be picked freely, C<CPAN.pm> always reads
10493 all files (in alphabetical order) and takes the key C<match> (see
10494 below in I<Language Specs>) as a hashref containing match criteria
10495 that determine if the current distribution matches the YAML document
10496 or not.
10497
10498 =head2 Fallback Data::Dumper and Storable
10499
10500 If neither your configured C<yaml_module> nor YAML.pm is installed
10501 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10502 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10503 directory. These files are expected to contain one or more hashrefs.
10504 For Data::Dumper generated files, this is expected to be done with by
10505 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10506 with the command
10507
10508     ysh < somefile.yml > somefile.dd
10509
10510 For Storable files the rule is that they must be constructed such that
10511 C<Storable::retrieve(file)> returns an array reference and the array
10512 elements represent one distropref object each. The conversion from
10513 YAML would look like so:
10514
10515     perl -MYAML=LoadFile -MStorable=nstore -e '
10516         @y=LoadFile(shift);
10517         nstore(\@y, shift)' somefile.yml somefile.st
10518
10519 In bootstrapping situations it is usually sufficient to translate only
10520 a few YAML files to Data::Dumper for the crucial modules like
10521 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10522 over Data::Dumper, remember to pull out a Storable version that writes
10523 an older format than all the other Storable versions that will need to
10524 read them.
10525
10526 =head2 Blueprint
10527
10528 The following example contains all supported keywords and structures
10529 with the exception of C<eexpect> which can be used instead of
10530 C<expect>.
10531
10532   ---
10533   comment: "Demo"
10534   match:
10535     module: "Dancing::Queen"
10536     distribution: "^CHACHACHA/Dancing-"
10537     perl: "/usr/local/cariba-perl/bin/perl"
10538     perlconfig:
10539       archname: "freebsd"
10540   disabled: 1
10541   cpanconfig:
10542     make: gmake
10543   pl:
10544     args:
10545       - "--somearg=specialcase"
10546
10547     env: {}
10548
10549     expect:
10550       - "Which is your favorite fruit"
10551       - "apple\n"
10552
10553   make:
10554     args:
10555       - all
10556       - extra-all
10557
10558     env: {}
10559
10560     expect: []
10561
10562     commendline: "echo SKIPPING make"
10563
10564   test:
10565     args: []
10566
10567     env: {}
10568
10569     expect: []
10570
10571   install:
10572     args: []
10573
10574     env:
10575       WANT_TO_INSTALL: YES
10576
10577     expect:
10578       - "Do you really want to install"
10579       - "y\n"
10580
10581   patches:
10582     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10583
10584
10585 =head2 Language Specs
10586
10587 Every YAML document represents a single hash reference. The valid keys
10588 in this hash are as follows:
10589
10590 =over
10591
10592 =item comment [scalar]
10593
10594 A comment
10595
10596 =item cpanconfig [hash]
10597
10598 Temporarily override assorted C<CPAN.pm> configuration variables.
10599
10600 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10601 C<make>, C<make_install_make_command>, C<prefer_installer>,
10602 C<test_report>. Please report as a bug when you need another one
10603 supported.
10604
10605 =item disabled [boolean]
10606
10607 Specifies that this distribution shall not be processed at all.
10608
10609 =item goto [string]
10610
10611 The canonical name of a delegate distribution that shall be installed
10612 instead. Useful when a new version, although it tests OK itself,
10613 breaks something else or a developer release or a fork is already
10614 uploaded that is better than the last released version.
10615
10616 =item install [hash]
10617
10618 Processing instructions for the C<make install> or C<./Build install>
10619 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10620
10621 =item make [hash]
10622
10623 Processing instructions for the C<make> or C<./Build> phase of the
10624 CPAN mantra. See below under I<Processiong Instructions>.
10625
10626 =item match [hash]
10627
10628 A hashref with one or more of the keys C<distribution>, C<modules>,
10629 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10630 specific CPAN distribution or installation.
10631
10632 The corresponding values are interpreted as regular expressions. The
10633 C<distribution> related one will be matched against the canonical
10634 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10635
10636 The C<module> related one will be matched against I<all> modules
10637 contained in the distribution until one module matches.
10638
10639 The C<perl> related one will be matched against C<$^X>.
10640
10641 The value associated with C<perlconfig> is itself a hashref that is
10642 matched against corresponding values in the C<%Config::Config> hash
10643 living in the C< Config.pm > module.
10644
10645 If more than one restriction of C<module>, C<distribution>, and
10646 C<perl> is specified, the results of the separately computed match
10647 values must all match. If this is the case then the hashref
10648 represented by the YAML document is returned as the preference
10649 structure for the current distribution.
10650
10651 =item patches [array]
10652
10653 An array of patches on CPAN or on the local disk to be applied in
10654 order via the external patch program. If the value for the C<-p>
10655 parameter is C<0> or C<1> is determined by reading the patch
10656 beforehand.
10657
10658 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10659 knows about it B<and> a patch is written by the C<makepatch> program,
10660 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10661 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10662 distribution.
10663
10664 =item pl [hash]
10665
10666 Processing instructions for the C<perl Makefile.PL> or C<perl
10667 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10668 Instructions>.
10669
10670 =item test [hash]
10671
10672 Processing instructions for the C<make test> or C<./Build test> phase
10673 of the CPAN mantra. See below under I<Processiong Instructions>.
10674
10675 =back
10676
10677 =head2 Processing Instructions
10678
10679 =over
10680
10681 =item args [array]
10682
10683 Arguments to be added to the command line
10684
10685 =item commandline
10686
10687 A full commandline that will be executed as it stands by a system
10688 call. During the execution the environment variable PERL will is set
10689 to $^X. If C<commandline> is specified, the content of C<args> is not
10690 used.
10691
10692 =item eexpect [hash]
10693
10694 Extended C<expect>. This is a hash reference with three allowed keys,
10695 C<mode>, C<timeout>, and C<talk>.
10696
10697 C<mode> may have the values C<deterministic> for the case where all
10698 questions come in the order written down and C<anyorder> for the case
10699 where the questions may come in any order. The default mode is
10700 C<deterministic>.
10701
10702 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10703 OK. In the case of a C<mode=deterministic> the timeout denotes the
10704 timeout per question, in the case of C<mode=anyorder> it denotes the
10705 timeout per byte received from the stream or questions.
10706
10707 C<talk> is a reference to an array that contains alternating questions
10708 and answers. Questions are regular expressions and answers are literal
10709 strings. The Expect module will then watch the stream coming from the
10710 execution of the external program (C<perl Makefile.PL>, C<perl
10711 Build.PL>, C<make>, etc.).
10712
10713 In the case of C<mode=deterministic> the CPAN.pm will inject the
10714 according answer as soon as the stream matches the regular expression.
10715 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10716 soon as the timeout is reached for the next byte in the input stream.
10717 In the latter case it removes the according question/answer pair from
10718 the array, so if you want to answer the question C<Do you really want
10719 to do that> several times, then it must be included in the array at
10720 least as often as you want this answer to be given.
10721
10722 =item env [hash]
10723
10724 Environment variables to be set during the command
10725
10726 =item expect [array]
10727
10728 C<< expect: <array> >> is a short notation for
10729
10730   eexpect:
10731     mode: deterministic
10732     timeout: 15
10733     talk: <array>
10734
10735 =back
10736
10737 =head2 Schema verification with C<Kwalify>
10738
10739 If you have the C<Kwalify> module installed (which is part of the
10740 Bundle::CPANxxl), then all your distroprefs files are checked for
10741 syntactical correctness.
10742
10743 =head2 Example Distroprefs Files
10744
10745 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10746 are really just examples and should not be used without care because
10747 they cannot fit everybody's purpose. After all the authors of the
10748 packages that ask questions had a need to ask, so you should watch
10749 their questions and adjust the examples to your environment and your
10750 needs. You have beend warned:-)
10751
10752 =head1 PROGRAMMER'S INTERFACE
10753
10754 If you do not enter the shell, the available shell commands are both
10755 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10756 functions in the calling package (C<install(...)>).  Before calling low-level
10757 commands it makes sense to initialize components of CPAN you need, e.g.:
10758
10759   CPAN::HandleConfig->load;
10760   CPAN::Shell::setup_output;
10761   CPAN::Index->reload;
10762
10763 High-level commands do such initializations automatically.
10764
10765 There's currently only one class that has a stable interface -
10766 CPAN::Shell. All commands that are available in the CPAN shell are
10767 methods of the class CPAN::Shell. Each of the commands that produce
10768 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10769 the IDs of all modules within the list.
10770
10771 =over 2
10772
10773 =item expand($type,@things)
10774
10775 The IDs of all objects available within a program are strings that can
10776 be expanded to the corresponding real objects with the
10777 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10778 list of CPAN::Module objects according to the C<@things> arguments
10779 given. In scalar context it only returns the first element of the
10780 list.
10781
10782 =item expandany(@things)
10783
10784 Like expand, but returns objects of the appropriate type, i.e.
10785 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10786 CPAN::Distribution objects for distributions. Note: it does not expand
10787 to CPAN::Author objects.
10788
10789 =item Programming Examples
10790
10791 This enables the programmer to do operations that combine
10792 functionalities that are available in the shell.
10793
10794     # install everything that is outdated on my disk:
10795     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10796
10797     # install my favorite programs if necessary:
10798     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10799         CPAN::Shell->install($mod);
10800     }
10801
10802     # list all modules on my disk that have no VERSION number
10803     for $mod (CPAN::Shell->expand("Module","/./")){
10804         next unless $mod->inst_file;
10805         # MakeMaker convention for undefined $VERSION:
10806         next unless $mod->inst_version eq "undef";
10807         print "No VERSION in ", $mod->id, "\n";
10808     }
10809
10810     # find out which distribution on CPAN contains a module:
10811     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10812
10813 Or if you want to write a cronjob to watch The CPAN, you could list
10814 all modules that need updating. First a quick and dirty way:
10815
10816     perl -e 'use CPAN; CPAN::Shell->r;'
10817
10818 If you don't want to get any output in the case that all modules are
10819 up to date, you can parse the output of above command for the regular
10820 expression //modules are up to date// and decide to mail the output
10821 only if it doesn't match. Ick?
10822
10823 If you prefer to do it more in a programmer style in one single
10824 process, maybe something like this suits you better:
10825
10826   # list all modules on my disk that have newer versions on CPAN
10827   for $mod (CPAN::Shell->expand("Module","/./")){
10828     next unless $mod->inst_file;
10829     next if $mod->uptodate;
10830     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10831         $mod->id, $mod->inst_version, $mod->cpan_version;
10832   }
10833
10834 If that gives you too much output every day, you maybe only want to
10835 watch for three modules. You can write
10836
10837   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10838
10839 as the first line instead. Or you can combine some of the above
10840 tricks:
10841
10842   # watch only for a new mod_perl module
10843   $mod = CPAN::Shell->expand("Module","mod_perl");
10844   exit if $mod->uptodate;
10845   # new mod_perl arrived, let me know all update recommendations
10846   CPAN::Shell->r;
10847
10848 =back
10849
10850 =head2 Methods in the other Classes
10851
10852 =over 4
10853
10854 =item CPAN::Author::as_glimpse()
10855
10856 Returns a one-line description of the author
10857
10858 =item CPAN::Author::as_string()
10859
10860 Returns a multi-line description of the author
10861
10862 =item CPAN::Author::email()
10863
10864 Returns the author's email address
10865
10866 =item CPAN::Author::fullname()
10867
10868 Returns the author's name
10869
10870 =item CPAN::Author::name()
10871
10872 An alias for fullname
10873
10874 =item CPAN::Bundle::as_glimpse()
10875
10876 Returns a one-line description of the bundle
10877
10878 =item CPAN::Bundle::as_string()
10879
10880 Returns a multi-line description of the bundle
10881
10882 =item CPAN::Bundle::clean()
10883
10884 Recursively runs the C<clean> method on all items contained in the bundle.
10885
10886 =item CPAN::Bundle::contains()
10887
10888 Returns a list of objects' IDs contained in a bundle. The associated
10889 objects may be bundles, modules or distributions.
10890
10891 =item CPAN::Bundle::force($method,@args)
10892
10893 Forces CPAN to perform a task that it normally would have refused to
10894 do. Force takes as arguments a method name to be called and any number
10895 of additional arguments that should be passed to the called method.
10896 The internals of the object get the needed changes so that CPAN.pm
10897 does not refuse to take the action. The C<force> is passed recursively
10898 to all contained objects. See also the section above on the C<force>
10899 and the C<fforce> pragma.
10900
10901 =item CPAN::Bundle::get()
10902
10903 Recursively runs the C<get> method on all items contained in the bundle
10904
10905 =item CPAN::Bundle::inst_file()
10906
10907 Returns the highest installed version of the bundle in either @INC or
10908 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10909 CPAN::Module::inst_file.
10910
10911 =item CPAN::Bundle::inst_version()
10912
10913 Like CPAN::Bundle::inst_file, but returns the $VERSION
10914
10915 =item CPAN::Bundle::uptodate()
10916
10917 Returns 1 if the bundle itself and all its members are uptodate.
10918
10919 =item CPAN::Bundle::install()
10920
10921 Recursively runs the C<install> method on all items contained in the bundle
10922
10923 =item CPAN::Bundle::make()
10924
10925 Recursively runs the C<make> method on all items contained in the bundle
10926
10927 =item CPAN::Bundle::readme()
10928
10929 Recursively runs the C<readme> method on all items contained in the bundle
10930
10931 =item CPAN::Bundle::test()
10932
10933 Recursively runs the C<test> method on all items contained in the bundle
10934
10935 =item CPAN::Distribution::as_glimpse()
10936
10937 Returns a one-line description of the distribution
10938
10939 =item CPAN::Distribution::as_string()
10940
10941 Returns a multi-line description of the distribution
10942
10943 =item CPAN::Distribution::author
10944
10945 Returns the CPAN::Author object of the maintainer who uploaded this
10946 distribution
10947
10948 =item CPAN::Distribution::clean()
10949
10950 Changes to the directory where the distribution has been unpacked and
10951 runs C<make clean> there.
10952
10953 =item CPAN::Distribution::containsmods()
10954
10955 Returns a list of IDs of modules contained in a distribution file.
10956 Only works for distributions listed in the 02packages.details.txt.gz
10957 file. This typically means that only the most recent version of a
10958 distribution is covered.
10959
10960 =item CPAN::Distribution::cvs_import()
10961
10962 Changes to the directory where the distribution has been unpacked and
10963 runs something like
10964
10965     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10966
10967 there.
10968
10969 =item CPAN::Distribution::dir()
10970
10971 Returns the directory into which this distribution has been unpacked.
10972
10973 =item CPAN::Distribution::force($method,@args)
10974
10975 Forces CPAN to perform a task that it normally would have refused to
10976 do. Force takes as arguments a method name to be called and any number
10977 of additional arguments that should be passed to the called method.
10978 The internals of the object get the needed changes so that CPAN.pm
10979 does not refuse to take the action. See also the section above on the
10980 C<force> and the C<fforce> pragma.
10981
10982 =item CPAN::Distribution::get()
10983
10984 Downloads the distribution from CPAN and unpacks it. Does nothing if
10985 the distribution has already been downloaded and unpacked within the
10986 current session.
10987
10988 =item CPAN::Distribution::install()
10989
10990 Changes to the directory where the distribution has been unpacked and
10991 runs the external command C<make install> there. If C<make> has not
10992 yet been run, it will be run first. A C<make test> will be issued in
10993 any case and if this fails, the install will be canceled. The
10994 cancellation can be avoided by letting C<force> run the C<install> for
10995 you.
10996
10997 This install method has only the power to install the distribution if
10998 there are no dependencies in the way. To install an object and all of
10999 its dependencies, use CPAN::Shell->install.
11000
11001 Note that install() gives no meaningful return value. See uptodate().
11002
11003 =item CPAN::Distribution::install_tested()
11004
11005 Install all the distributions that have been tested sucessfully but
11006 not yet installed. See also C<is_tested>.
11007
11008 =item CPAN::Distribution::isa_perl()
11009
11010 Returns 1 if this distribution file seems to be a perl distribution.
11011 Normally this is derived from the file name only, but the index from
11012 CPAN can contain a hint to achieve a return value of true for other
11013 filenames too.
11014
11015 =item CPAN::Distribution::is_tested()
11016
11017 List all the distributions that have been tested sucessfully but not
11018 yet installed. See also C<install_tested>.
11019
11020 =item CPAN::Distribution::look()
11021
11022 Changes to the directory where the distribution has been unpacked and
11023 opens a subshell there. Exiting the subshell returns.
11024
11025 =item CPAN::Distribution::make()
11026
11027 First runs the C<get> method to make sure the distribution is
11028 downloaded and unpacked. Changes to the directory where the
11029 distribution has been unpacked and runs the external commands C<perl
11030 Makefile.PL> or C<perl Build.PL> and C<make> there.
11031
11032 =item CPAN::Distribution::perldoc()
11033
11034 Downloads the pod documentation of the file associated with a
11035 distribution (in html format) and runs it through the external
11036 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
11037 isn't available, it converts it to plain text with external
11038 command html2text and runs it through the pager specified
11039 in C<$CPAN::Config->{pager}>
11040
11041 =item CPAN::Distribution::prefs()
11042
11043 Returns the hash reference from the first matching YAML file that the
11044 user has deposited in the C<prefs_dir/> directory. The first
11045 succeeding match wins. The files in the C<prefs_dir/> are processed
11046 alphabetically and the canonical distroname (e.g.
11047 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
11048 stored in the $root->{match}{distribution} attribute value.
11049 Additionally all module names contained in a distribution are matched
11050 agains the regular expressions in the $root->{match}{module} attribute
11051 value. The two match values are ANDed together. Each of the two
11052 attributes are optional.
11053
11054 =item CPAN::Distribution::prereq_pm()
11055
11056 Returns the hash reference that has been announced by a distribution
11057 as the the C<requires> and C<build_requires> elements. These can be
11058 declared either by the C<META.yml> (if authoritative) or can be
11059 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
11060 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
11061 a comment in the produced C<Makefile>. I<Note>: this method only works
11062 after an attempt has been made to C<make> the distribution. Returns
11063 undef otherwise.
11064
11065 =item CPAN::Distribution::readme()
11066
11067 Downloads the README file associated with a distribution and runs it
11068 through the pager specified in C<$CPAN::Config->{pager}>.
11069
11070 =item CPAN::Distribution::reports()
11071
11072 Downloads report data for this distribution from cpantesters.perl.org
11073 and displays a subset of them.
11074
11075 =item CPAN::Distribution::read_yaml()
11076
11077 Returns the content of the META.yml of this distro as a hashref. Note:
11078 works only after an attempt has been made to C<make> the distribution.
11079 Returns undef otherwise. Also returns undef if the content of META.yml
11080 is not authoritative. (The rules about what exactly makes the content
11081 authoritative are still in flux.)
11082
11083 =item CPAN::Distribution::test()
11084
11085 Changes to the directory where the distribution has been unpacked and
11086 runs C<make test> there.
11087
11088 =item CPAN::Distribution::uptodate()
11089
11090 Returns 1 if all the modules contained in the distribution are
11091 uptodate. Relies on containsmods.
11092
11093 =item CPAN::Index::force_reload()
11094
11095 Forces a reload of all indices.
11096
11097 =item CPAN::Index::reload()
11098
11099 Reloads all indices if they have not been read for more than
11100 C<$CPAN::Config->{index_expire}> days.
11101
11102 =item CPAN::InfoObj::dump()
11103
11104 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
11105 inherit this method. It prints the data structure associated with an
11106 object. Useful for debugging. Note: the data structure is considered
11107 internal and thus subject to change without notice.
11108
11109 =item CPAN::Module::as_glimpse()
11110
11111 Returns a one-line description of the module in four columns: The
11112 first column contains the word C<Module>, the second column consists
11113 of one character: an equals sign if this module is already installed
11114 and uptodate, a less-than sign if this module is installed but can be
11115 upgraded, and a space if the module is not installed. The third column
11116 is the name of the module and the fourth column gives maintainer or
11117 distribution information.
11118
11119 =item CPAN::Module::as_string()
11120
11121 Returns a multi-line description of the module
11122
11123 =item CPAN::Module::clean()
11124
11125 Runs a clean on the distribution associated with this module.
11126
11127 =item CPAN::Module::cpan_file()
11128
11129 Returns the filename on CPAN that is associated with the module.
11130
11131 =item CPAN::Module::cpan_version()
11132
11133 Returns the latest version of this module available on CPAN.
11134
11135 =item CPAN::Module::cvs_import()
11136
11137 Runs a cvs_import on the distribution associated with this module.
11138
11139 =item CPAN::Module::description()
11140
11141 Returns a 44 character description of this module. Only available for
11142 modules listed in The Module List (CPAN/modules/00modlist.long.html
11143 or 00modlist.long.txt.gz)
11144
11145 =item CPAN::Module::distribution()
11146
11147 Returns the CPAN::Distribution object that contains the current
11148 version of this module.
11149
11150 =item CPAN::Module::dslip_status()
11151
11152 Returns a hash reference. The keys of the hash are the letters C<D>,
11153 C<S>, C<L>, C<I>, and <P>, for development status, support level,
11154 language, interface and public licence respectively. The data for the
11155 DSLIP status are collected by pause.perl.org when authors register
11156 their namespaces. The values of the 5 hash elements are one-character
11157 words whose meaning is described in the table below. There are also 5
11158 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
11159 verbose value of the 5 status variables.
11160
11161 Where the 'DSLIP' characters have the following meanings:
11162
11163   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
11164     i   - Idea, listed to gain consensus or as a placeholder
11165     c   - under construction but pre-alpha (not yet released)
11166     a/b - Alpha/Beta testing
11167     R   - Released
11168     M   - Mature (no rigorous definition)
11169     S   - Standard, supplied with Perl 5
11170
11171   S - Support Level:
11172     m   - Mailing-list
11173     d   - Developer
11174     u   - Usenet newsgroup comp.lang.perl.modules
11175     n   - None known, try comp.lang.perl.modules
11176     a   - abandoned; volunteers welcome to take over maintainance
11177
11178   L - Language Used:
11179     p   - Perl-only, no compiler needed, should be platform independent
11180     c   - C and perl, a C compiler will be needed
11181     h   - Hybrid, written in perl with optional C code, no compiler needed
11182     +   - C++ and perl, a C++ compiler will be needed
11183     o   - perl and another language other than C or C++
11184
11185   I - Interface Style
11186     f   - plain Functions, no references used
11187     h   - hybrid, object and function interfaces available
11188     n   - no interface at all (huh?)
11189     r   - some use of unblessed References or ties
11190     O   - Object oriented using blessed references and/or inheritance
11191
11192   P - Public License
11193     p   - Standard-Perl: user may choose between GPL and Artistic
11194     g   - GPL: GNU General Public License
11195     l   - LGPL: "GNU Lesser General Public License" (previously known as
11196           "GNU Library General Public License")
11197     b   - BSD: The BSD License
11198     a   - Artistic license alone
11199     o   - open source: appoved by www.opensource.org
11200     d   - allows distribution without restrictions
11201     r   - restricted distribtion
11202     n   - no license at all
11203
11204 =item CPAN::Module::force($method,@args)
11205
11206 Forces CPAN to perform a task that it normally would have refused to
11207 do. Force takes as arguments a method name to be called and any number
11208 of additional arguments that should be passed to the called method.
11209 The internals of the object get the needed changes so that CPAN.pm
11210 does not refuse to take the action. See also the section above on the
11211 C<force> and the C<fforce> pragma.
11212
11213 =item CPAN::Module::get()
11214
11215 Runs a get on the distribution associated with this module.
11216
11217 =item CPAN::Module::inst_file()
11218
11219 Returns the filename of the module found in @INC. The first file found
11220 is reported just like perl itself stops searching @INC when it finds a
11221 module.
11222
11223 =item CPAN::Module::available_file()
11224
11225 Returns the filename of the module found in PERL5LIB or @INC. The
11226 first file found is reported. The advantage of this method over
11227 C<inst_file> is that modules that have been tested but not yet
11228 installed are included because PERL5LIB keeps track of tested modules.
11229
11230 =item CPAN::Module::inst_version()
11231
11232 Returns the version number of the installed module in readable format.
11233
11234 =item CPAN::Module::available_version()
11235
11236 Returns the version number of the available module in readable format.
11237
11238 =item CPAN::Module::install()
11239
11240 Runs an C<install> on the distribution associated with this module.
11241
11242 =item CPAN::Module::look()
11243
11244 Changes to the directory where the distribution associated with this
11245 module has been unpacked and opens a subshell there. Exiting the
11246 subshell returns.
11247
11248 =item CPAN::Module::make()
11249
11250 Runs a C<make> on the distribution associated with this module.
11251
11252 =item CPAN::Module::manpage_headline()
11253
11254 If module is installed, peeks into the module's manpage, reads the
11255 headline and returns it. Moreover, if the module has been downloaded
11256 within this session, does the equivalent on the downloaded module even
11257 if it is not installed.
11258
11259 =item CPAN::Module::perldoc()
11260
11261 Runs a C<perldoc> on this module.
11262
11263 =item CPAN::Module::readme()
11264
11265 Runs a C<readme> on the distribution associated with this module.
11266
11267 =item CPAN::Module::reports()
11268
11269 Calls the reports() method on the associated distribution object.
11270
11271 =item CPAN::Module::test()
11272
11273 Runs a C<test> on the distribution associated with this module.
11274
11275 =item CPAN::Module::uptodate()
11276
11277 Returns 1 if the module is installed and up-to-date.
11278
11279 =item CPAN::Module::userid()
11280
11281 Returns the author's ID of the module.
11282
11283 =back
11284
11285 =head2 Cache Manager
11286
11287 Currently the cache manager only keeps track of the build directory
11288 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11289 deletes complete directories below C<build_dir> as soon as the size of
11290 all directories there gets bigger than $CPAN::Config->{build_cache}
11291 (in MB). The contents of this cache may be used for later
11292 re-installations that you intend to do manually, but will never be
11293 trusted by CPAN itself. This is due to the fact that the user might
11294 use these directories for building modules on different architectures.
11295
11296 There is another directory ($CPAN::Config->{keep_source_where}) where
11297 the original distribution files are kept. This directory is not
11298 covered by the cache manager and must be controlled by the user. If
11299 you choose to have the same directory as build_dir and as
11300 keep_source_where directory, then your sources will be deleted with
11301 the same fifo mechanism.
11302
11303 =head2 Bundles
11304
11305 A bundle is just a perl module in the namespace Bundle:: that does not
11306 define any functions or methods. It usually only contains documentation.
11307
11308 It starts like a perl module with a package declaration and a $VERSION
11309 variable. After that the pod section looks like any other pod with the
11310 only difference being that I<one special pod section> exists starting with
11311 (verbatim):
11312
11313         =head1 CONTENTS
11314
11315 In this pod section each line obeys the format
11316
11317         Module_Name [Version_String] [- optional text]
11318
11319 The only required part is the first field, the name of a module
11320 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11321 of the line is optional. The comment part is delimited by a dash just
11322 as in the man page header.
11323
11324 The distribution of a bundle should follow the same convention as
11325 other distributions.
11326
11327 Bundles are treated specially in the CPAN package. If you say 'install
11328 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11329 the modules in the CONTENTS section of the pod. You can install your
11330 own Bundles locally by placing a conformant Bundle file somewhere into
11331 your @INC path. The autobundle() command which is available in the
11332 shell interface does that for you by including all currently installed
11333 modules in a snapshot bundle file.
11334
11335 =head1 PREREQUISITES
11336
11337 If you have a local mirror of CPAN and can access all files with
11338 "file:" URLs, then you only need a perl better than perl5.003 to run
11339 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11340 required for non-UNIX systems or if your nearest CPAN site is
11341 associated with a URL that is not C<ftp:>.
11342
11343 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11344 implemented for an external ftp command or for an external lynx
11345 command.
11346
11347 =head1 UTILITIES
11348
11349 =head2 Finding packages and VERSION
11350
11351 This module presumes that all packages on CPAN
11352
11353 =over 2
11354
11355 =item *
11356
11357 declare their $VERSION variable in an easy to parse manner. This
11358 prerequisite can hardly be relaxed because it consumes far too much
11359 memory to load all packages into the running program just to determine
11360 the $VERSION variable. Currently all programs that are dealing with
11361 version use something like this
11362
11363     perl -MExtUtils::MakeMaker -le \
11364         'print MM->parse_version(shift)' filename
11365
11366 If you are author of a package and wonder if your $VERSION can be
11367 parsed, please try the above method.
11368
11369 =item *
11370
11371 come as compressed or gzipped tarfiles or as zip files and contain a
11372 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11373 without much enthusiasm).
11374
11375 =back
11376
11377 =head2 Debugging
11378
11379 The debugging of this module is a bit complex, because we have
11380 interferences of the software producing the indices on CPAN, of the
11381 mirroring process on CPAN, of packaging, of configuration, of
11382 synchronicity, and of bugs within CPAN.pm.
11383
11384 For debugging the code of CPAN.pm itself in interactive mode some more
11385 or less useful debugging aid can be turned on for most packages within
11386 CPAN.pm with one of
11387
11388 =over 2
11389
11390 =item o debug package...
11391
11392 sets debug mode for packages.
11393
11394 =item o debug -package...
11395
11396 unsets debug mode for packages.
11397
11398 =item o debug all
11399
11400 turns debugging on for all packages.
11401
11402 =item o debug number
11403
11404 =back
11405
11406 which sets the debugging packages directly. Note that C<o debug 0>
11407 turns debugging off.
11408
11409 What seems quite a successful strategy is the combination of C<reload
11410 cpan> and the debugging switches. Add a new debug statement while
11411 running in the shell and then issue a C<reload cpan> and see the new
11412 debugging messages immediately without losing the current context.
11413
11414 C<o debug> without an argument lists the valid package names and the
11415 current set of packages in debugging mode. C<o debug> has built-in
11416 completion support.
11417
11418 For debugging of CPAN data there is the C<dump> command which takes
11419 the same arguments as make/test/install and outputs each object's
11420 Data::Dumper dump. If an argument looks like a perl variable and
11421 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11422 Data::Dumper directly.
11423
11424 =head2 Floppy, Zip, Offline Mode
11425
11426 CPAN.pm works nicely without network too. If you maintain machines
11427 that are not networked at all, you should consider working with file:
11428 URLs. Of course, you have to collect your modules somewhere first. So
11429 you might use CPAN.pm to put together all you need on a networked
11430 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11431 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11432 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11433 with this floppy. See also below the paragraph about CD-ROM support.
11434
11435 =head2 Basic Utilities for Programmers
11436
11437 =over 2
11438
11439 =item has_inst($module)
11440
11441 Returns true if the module is installed. Used to load all modules into
11442 the running CPAN.pm which are considered optional. The config variable
11443 C<dontload_list> can be used to intercept the C<has_inst()> call such
11444 that an optional module is not loaded despite being available. For
11445 example the following command will prevent that C<YAML.pm> is being
11446 loaded:
11447
11448     cpan> o conf dontload_list push YAML
11449
11450 See the source for details.
11451
11452 =item has_usable($module)
11453
11454 Returns true if the module is installed and is in a usable state. Only
11455 useful for a handful of modules that are used internally. See the
11456 source for details.
11457
11458 =item instance($module)
11459
11460 The constructor for all the singletons used to represent modules,
11461 distributions, authors and bundles. If the object already exists, this
11462 method returns the object, otherwise it calls the constructor.
11463
11464 =back
11465
11466 =head1 SECURITY
11467
11468 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11469 install foreign, unmasked, unsigned code on your machine. We compare
11470 to a checksum that comes from the net just as the distribution file
11471 itself. But we try to make it easy to add security on demand:
11472
11473 =head2 Cryptographically signed modules
11474
11475 Since release 1.77 CPAN.pm has been able to verify cryptographically
11476 signed module distributions using Module::Signature.  The CPAN modules
11477 can be signed by their authors, thus giving more security.  The simple
11478 unsigned MD5 checksums that were used before by CPAN protect mainly
11479 against accidental file corruption.
11480
11481 You will need to have Module::Signature installed, which in turn
11482 requires that you have at least one of Crypt::OpenPGP module or the
11483 command-line F<gpg> tool installed.
11484
11485 You will also need to be able to connect over the Internet to the public
11486 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11487
11488 The configuration parameter check_sigs is there to turn signature
11489 checking on or off.
11490
11491 =head1 EXPORT
11492
11493 Most functions in package CPAN are exported per default. The reason
11494 for this is that the primary use is intended for the cpan shell or for
11495 one-liners.
11496
11497 =head1 ENVIRONMENT
11498
11499 When the CPAN shell enters a subshell via the look command, it sets
11500 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11501 already set.
11502
11503 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11504
11505 When the config variable ftp_passive is set, all downloads will be run
11506 with the environment variable FTP_PASSIVE set to this value. This is
11507 in general a good idea as it influences both Net::FTP and LWP based
11508 connections. The same effect can be achieved by starting the cpan
11509 shell with this environment variable set. For Net::FTP alone, one can
11510 also always set passive mode by running libnetcfg.
11511
11512 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11513
11514 Populating a freshly installed perl with my favorite modules is pretty
11515 easy if you maintain a private bundle definition file. To get a useful
11516 blueprint of a bundle definition file, the command autobundle can be used
11517 on the CPAN shell command line. This command writes a bundle definition
11518 file for all modules that are installed for the currently running perl
11519 interpreter. It's recommended to run this command only once and from then
11520 on maintain the file manually under a private name, say
11521 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11522
11523     cpan> install Bundle::my_bundle
11524
11525 then answer a few questions and then go out for a coffee.
11526
11527 Maintaining a bundle definition file means keeping track of two
11528 things: dependencies and interactivity. CPAN.pm sometimes fails on
11529 calculating dependencies because not all modules define all MakeMaker
11530 attributes correctly, so a bundle definition file should specify
11531 prerequisites as early as possible. On the other hand, it's a bit
11532 annoying that many distributions need some interactive configuring. So
11533 what I try to accomplish in my private bundle file is to have the
11534 packages that need to be configured early in the file and the gentle
11535 ones later, so I can go out after a few minutes and leave CPAN.pm
11536 untended.
11537
11538 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11539
11540 Thanks to Graham Barr for contributing the following paragraphs about
11541 the interaction between perl, and various firewall configurations. For
11542 further information on firewalls, it is recommended to consult the
11543 documentation that comes with the ncftp program. If you are unable to
11544 go through the firewall with a simple Perl setup, it is very likely
11545 that you can configure ncftp so that it works for your firewall.
11546
11547 =head2 Three basic types of firewalls
11548
11549 Firewalls can be categorized into three basic types.
11550
11551 =over 4
11552
11553 =item http firewall
11554
11555 This is where the firewall machine runs a web server and to access the
11556 outside world you must do it via the web server. If you set environment
11557 variables like http_proxy or ftp_proxy to a values beginning with http://
11558 or in your web browser you have to set proxy information then you know
11559 you are running an http firewall.
11560
11561 To access servers outside these types of firewalls with perl (even for
11562 ftp) you will need to use LWP.
11563
11564 =item ftp firewall
11565
11566 This where the firewall machine runs an ftp server. This kind of
11567 firewall will only let you access ftp servers outside the firewall.
11568 This is usually done by connecting to the firewall with ftp, then
11569 entering a username like "user@outside.host.com"
11570
11571 To access servers outside these type of firewalls with perl you
11572 will need to use Net::FTP.
11573
11574 =item One way visibility
11575
11576 I say one way visibility as these firewalls try to make themselves look
11577 invisible to the users inside the firewall. An FTP data connection is
11578 normally created by sending the remote server your IP address and then
11579 listening for the connection. But the remote server will not be able to
11580 connect to you because of the firewall. So for these types of firewall
11581 FTP connections need to be done in a passive mode.
11582
11583 There are two that I can think off.
11584
11585 =over 4
11586
11587 =item SOCKS
11588
11589 If you are using a SOCKS firewall you will need to compile perl and link
11590 it with the SOCKS library, this is what is normally called a 'socksified'
11591 perl. With this executable you will be able to connect to servers outside
11592 the firewall as if it is not there.
11593
11594 =item IP Masquerade
11595
11596 This is the firewall implemented in the Linux kernel, it allows you to
11597 hide a complete network behind one IP address. With this firewall no
11598 special compiling is needed as you can access hosts directly.
11599
11600 For accessing ftp servers behind such firewalls you usually need to
11601 set the environment variable C<FTP_PASSIVE> or the config variable
11602 ftp_passive to a true value.
11603
11604 =back
11605
11606 =back
11607
11608 =head2 Configuring lynx or ncftp for going through a firewall
11609
11610 If you can go through your firewall with e.g. lynx, presumably with a
11611 command such as
11612
11613     /usr/local/bin/lynx -pscott:tiger
11614
11615 then you would configure CPAN.pm with the command
11616
11617     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11618
11619 That's all. Similarly for ncftp or ftp, you would configure something
11620 like
11621
11622     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11623
11624 Your mileage may vary...
11625
11626 =head1 FAQ
11627
11628 =over 4
11629
11630 =item 1)
11631
11632 I installed a new version of module X but CPAN keeps saying,
11633 I have the old version installed
11634
11635 Most probably you B<do> have the old version installed. This can
11636 happen if a module installs itself into a different directory in the
11637 @INC path than it was previously installed. This is not really a
11638 CPAN.pm problem, you would have the same problem when installing the
11639 module manually. The easiest way to prevent this behaviour is to add
11640 the argument C<UNINST=1> to the C<make install> call, and that is why
11641 many people add this argument permanently by configuring
11642
11643   o conf make_install_arg UNINST=1
11644
11645 =item 2)
11646
11647 So why is UNINST=1 not the default?
11648
11649 Because there are people who have their precise expectations about who
11650 may install where in the @INC path and who uses which @INC array. In
11651 fine tuned environments C<UNINST=1> can cause damage.
11652
11653 =item 3)
11654
11655 I want to clean up my mess, and install a new perl along with
11656 all modules I have. How do I go about it?
11657
11658 Run the autobundle command for your old perl and optionally rename the
11659 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11660 with the Configure option prefix, e.g.
11661
11662     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11663
11664 Install the bundle file you produced in the first step with something like
11665
11666     cpan> install Bundle::mybundle
11667
11668 and you're done.
11669
11670 =item 4)
11671
11672 When I install bundles or multiple modules with one command
11673 there is too much output to keep track of.
11674
11675 You may want to configure something like
11676
11677   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11678   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11679
11680 so that STDOUT is captured in a file for later inspection.
11681
11682
11683 =item 5)
11684
11685 I am not root, how can I install a module in a personal directory?
11686
11687 First of all, you will want to use your own configuration, not the one
11688 that your root user installed. If you do not have permission to write
11689 in the cpan directory that root has configured, you will be asked if
11690 you want to create your own config. Answering "yes" will bring you into
11691 CPAN's configuration stage, using the system config for all defaults except
11692 things that have to do with CPAN's work directory, saving your choices to
11693 your MyConfig.pm file.
11694
11695 You can also manually initiate this process with the following command:
11696
11697     % perl -MCPAN -e 'mkmyconfig'
11698
11699 or by running
11700
11701     mkmyconfig
11702
11703 from the CPAN shell.
11704
11705 You will most probably also want to configure something like this:
11706
11707   o conf makepl_arg "LIB=~/myperl/lib \
11708                     INSTALLMAN1DIR=~/myperl/man/man1 \
11709                     INSTALLMAN3DIR=~/myperl/man/man3 \
11710                     INSTALLSCRIPT=~/myperl/bin \
11711                     INSTALLBIN=~/myperl/bin"
11712
11713 and then (oh joy) the equivalent command for Module::Build.
11714
11715 You can make this setting permanent like all C<o conf> settings with
11716 C<o conf commit> or by setting C<auto_commit> beforehand.
11717
11718 You will have to add ~/myperl/man to the MANPATH environment variable
11719 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11720 including
11721
11722   use lib "$ENV{HOME}/myperl/lib";
11723
11724 or setting the PERL5LIB environment variable.
11725
11726 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11727 that for Windows we use the File::HomeDir module that provides an
11728 equivalent to the concept of the home directory on Unix.
11729
11730 Another thing you should bear in mind is that the UNINST parameter can
11731 be dnagerous when you are installing into a private area because you
11732 might accidentally remove modules that other people depend on that are
11733 not using the private area.
11734
11735 =item 6)
11736
11737 How to get a package, unwrap it, and make a change before building it?
11738
11739 Have a look at the C<look> (!) command.
11740
11741 =item 7)
11742
11743 I installed a Bundle and had a couple of fails. When I
11744 retried, everything resolved nicely. Can this be fixed to work
11745 on first try?
11746
11747 The reason for this is that CPAN does not know the dependencies of all
11748 modules when it starts out. To decide about the additional items to
11749 install, it just uses data found in the META.yml file or the generated
11750 Makefile. An undetected missing piece breaks the process. But it may
11751 well be that your Bundle installs some prerequisite later than some
11752 depending item and thus your second try is able to resolve everything.
11753 Please note, CPAN.pm does not know the dependency tree in advance and
11754 cannot sort the queue of things to install in a topologically correct
11755 order. It resolves perfectly well IF all modules declare the
11756 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11757 the C<requires> stanza of Module::Build. For bundles which fail and
11758 you need to install often, it is recommended to sort the Bundle
11759 definition file manually.
11760
11761 =item 8)
11762
11763 In our intranet we have many modules for internal use. How
11764 can I integrate these modules with CPAN.pm but without uploading
11765 the modules to CPAN?
11766
11767 Have a look at the CPAN::Site module.
11768
11769 =item 9)
11770
11771 When I run CPAN's shell, I get an error message about things in my
11772 /etc/inputrc (or ~/.inputrc) file.
11773
11774 These are readline issues and can only be fixed by studying readline
11775 configuration on your architecture and adjusting the referenced file
11776 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11777 and edit them. Quite often harmless changes like uppercasing or
11778 lowercasing some arguments solves the problem.
11779
11780 =item 10)
11781
11782 Some authors have strange characters in their names.
11783
11784 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11785 expecting ISO-8859-1 charset, a converter can be activated by setting
11786 term_is_latin to a true value in your config file. One way of doing so
11787 would be
11788
11789     cpan> o conf term_is_latin 1
11790
11791 If other charset support is needed, please file a bugreport against
11792 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11793 the support or maybe UTF-8 terminals become widely available.
11794
11795 =item 11)
11796
11797 When an install fails for some reason and then I correct the error
11798 condition and retry, CPAN.pm refuses to install the module, saying
11799 C<Already tried without success>.
11800
11801 Use the force pragma like so
11802
11803   force install Foo::Bar
11804
11805 Or you can use
11806
11807   look Foo::Bar
11808
11809 and then 'make install' directly in the subshell.
11810
11811 =item 12)
11812
11813 How do I install a "DEVELOPER RELEASE" of a module?
11814
11815 By default, CPAN will install the latest non-developer release of a
11816 module. If you want to install a dev release, you have to specify the
11817 partial path starting with the author id to the tarball you wish to
11818 install, like so:
11819
11820     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11821
11822 Note that you can use the C<ls> command to get this path listed.
11823
11824 =item 13)
11825
11826 How do I install a module and all its dependencies from the commandline,
11827 without being prompted for anything, despite my CPAN configuration
11828 (or lack thereof)?
11829
11830 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11831 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11832 asked any questions at all (assuming the modules you are installing are
11833 nice about obeying that variable as well):
11834
11835     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11836
11837 =item 14)
11838
11839 How do I create a Module::Build based Build.PL derived from an
11840 ExtUtils::MakeMaker focused Makefile.PL?
11841
11842 http://search.cpan.org/search?query=Module::Build::Convert
11843
11844 http://www.refcnt.org/papers/module-build-convert
11845
11846 =item 15)
11847
11848 What's the best CPAN site for me?
11849
11850 The urllist config parameter is yours. You can add and remove sites at
11851 will. You should find out which sites have the best uptodateness,
11852 bandwidth, reliability, etc. and are topologically close to you. Some
11853 people prefer fast downloads, others uptodateness, others reliability.
11854 You decide which to try in which order.
11855
11856 Henk P. Penning maintains a site that collects data about CPAN sites:
11857
11858   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11859
11860 =back
11861
11862 =head1 COMPATIBILITY
11863
11864 =head2 OLD PERL VERSIONS
11865
11866 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11867 newer versions. It is getting more and more difficult to get the
11868 minimal prerequisites working on older perls. It is close to
11869 impossible to get the whole Bundle::CPAN working there. If you're in
11870 the position to have only these old versions, be advised that CPAN is
11871 designed to work fine without the Bundle::CPAN installed.
11872
11873 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11874 compatible with ancient perls and that File::Temp is listed as a
11875 prerequisite but CPAN has reasonable workarounds if it is missing.
11876
11877 =head2 CPANPLUS
11878
11879 This module and its competitor, the CPANPLUS module, are both much
11880 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11881 more modular but it was never tried to make it compatible with CPAN.pm.
11882
11883 =head1 SECURITY ADVICE
11884
11885 This software enables you to upgrade software on your computer and so
11886 is inherently dangerous because the newly installed software may
11887 contain bugs and may alter the way your computer works or even make it
11888 unusable. Please consider backing up your data before every upgrade.
11889
11890 =head1 BUGS
11891
11892 Please report bugs via http://rt.cpan.org/
11893
11894 Before submitting a bug, please make sure that the traditional method
11895 of building a Perl module package from a shell by following the
11896 installation instructions of that package still works in your
11897 environment.
11898
11899 =head1 AUTHOR
11900
11901 Andreas Koenig C<< <andk@cpan.org> >>
11902
11903 =head1 LICENSE
11904
11905 This program is free software; you can redistribute it and/or
11906 modify it under the same terms as Perl itself.
11907
11908 See L<http://www.perl.com/perl/misc/Artistic.html>
11909
11910 =head1 TRANSLATIONS
11911
11912 Kawai,Takanori provides a Japanese translation of this manpage at
11913 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11914
11915 =head1 SEE ALSO
11916
11917 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11918
11919 =cut
11920
11921