lib/CPAN.pm

   1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2 use strict;
   3 package CPAN;
   4 $CPAN::VERSION = '1.90';
   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                                     scripts
 524                                     test
 525                                     upgrade
 526 );
 527
 528 package CPAN::Index;
 529 use strict;
 530 use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED);
 531 @CPAN::Index::ISA = qw(CPAN::Debug);
 532 $LAST_TIME ||= 0;
 533 $DATE_OF_03 ||= 0;
 534 # use constant PROTOCOL => "2.0"; # outcommented to avoid warning on upgrade from 1.57
 535 sub PROTOCOL { 2.0 }
 536
 537 package CPAN::InfoObj;
 538 use strict;
 539 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
 540
 541 package CPAN::Author;
 542 use strict;
 543 @CPAN::Author::ISA = qw(CPAN::InfoObj);
 544
 545 package CPAN::Distribution;
 546 use strict;
 547 @CPAN::Distribution::ISA = qw(CPAN::InfoObj);
 548
 549 package CPAN::Bundle;
 550 use strict;
 551 @CPAN::Bundle::ISA = qw(CPAN::Module);
 552
 553 package CPAN::Module;
 554 use strict;
 555 @CPAN::Module::ISA = qw(CPAN::InfoObj);
 556
 557 package CPAN::Exception::RecursiveDependency;
 558 use strict;
 559 use overload '""' => "as_string";
 560
 561 # a module sees its distribution (no version)
 562 # a distribution sees its prereqs (which are module names) (usually with versions)
 563 # a bundle sees its module names and/or its distributions (no version)
 564
 565 sub new {
 566     my($class) = shift;
 567     my($deps) = shift;
 568     my (@deps,%seen,$loop_starts_with);
 569   DCHAIN: for my $dep (@$deps) {
 570         push @deps, {name => $dep, display_as => $dep};
 571         if ($seen{$dep}++){
 572             $loop_starts_with = $dep;
 573             last DCHAIN;
 574         }
 575     }
 576     my $in_loop = 0;
 577     for my $i (0..$#deps) {
 578         my $x = $deps[$i]{name};
 579         $in_loop ||= $x eq $loop_starts_with;
 580         my $xo = CPAN::Shell->expandany($x) or next;
 581         if ($xo->isa("CPAN::Module")) {
 582             my $have = $xo->inst_version || "N/A";
 583             my($want,$d,$want_type);
 584             if ($i>0 and $d = $deps[$i-1]{name}) {
 585                 my $do = CPAN::Shell->expandany($d);
 586                 $want = $do->{prereq_pm}{requires}{$x};
 587                 if (defined $want) {
 588                     $want_type = "requires: ";
 589                 } else {
 590                     $want = $do->{prereq_pm}{build_requires}{$x};
 591                     if (defined $want) {
 592                         $want_type = "build_requires: ";
 593                     } else {
 594                         $want_type = "unknown status";
 595                         $want = "???";
 596                     }
 597                 }
 598             } else {
 599                 $want = $xo->cpan_version;
 600                 $want_type = "want: ";
 601             }
 602             $deps[$i]{have} = $have;
 603             $deps[$i]{want_type} = $want_type;
 604             $deps[$i]{want} = $want;
 605             $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
 606         } elsif ($xo->isa("CPAN::Distribution")) {
 607             $deps[$i]{display_as} = $xo->pretty_id;
 608             if ($in_loop) {
 609                 $xo->{make} = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
 610             } else {
 611                 $xo->{make} = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
 612             }
 613             $xo->store_persistent_state; # otherwise I will not reach
 614                                          # all involved parties for
 615                                          # the next session
 616         }
 617     }
 618     bless { deps => \@deps }, $class;
 619 }
 620
 621 sub as_string {
 622     my($self) = shift;
 623     my $ret = "\nRecursive dependency detected:\n    ";
 624     $ret .= join("\n => ", map {$_->{display_as}} @{$self->{deps}});
 625     $ret .= ".\nCannot resolve.\n";
 626     $ret;
 627 }
 628
 629 package CPAN::Exception::yaml_not_installed;
 630 use strict;
 631 use overload '""' => "as_string";
 632
 633 sub new {
 634     my($class,$module,$file,$during) = @_;
 635     bless { module => $module, file => $file, during => $during }, $class;
 636 }
 637
 638 sub as_string {
 639     my($self) = shift;
 640     "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
 641 }
 642
 643 package CPAN::Exception::yaml_process_error;
 644 use strict;
 645 use overload '""' => "as_string";
 646
 647 sub new {
 648     my($class,$module,$file,$during,$error) = @_;
 649     bless { module => $module,
 650             file => $file,
 651             during => $during,
 652             error => $error }, $class;
 653 }
 654
 655 sub as_string {
 656     my($self) = shift;
 657     if ($self->{during}) {
 658         if ($self->{file}) {
 659             if ($self->{module}) {
 660                 if ($self->{error}) {
 661                     return "Alert: While trying to '$self->{during}' YAML file\n".
 662                         " '$self->{file}'\n".
 663                             "with '$self->{module}' the following error was encountered:\n".
 664                                 "  $self->{error}\n";
 665                 } else {
 666                     return "Alert: While trying to '$self->{during}' YAML file\n".
 667                         " '$self->{file}'\n".
 668                             "with '$self->{module}' some unknown error was encountered\n";
 669                 }
 670             } else {
 671                 return "Alert: While trying to '$self->{during}' YAML file\n".
 672                     " '$self->{file}'\n".
 673                         "some unknown error was encountered\n";
 674             }
 675         } else {
 676             return "Alert: While trying to '$self->{during}' some YAML file\n".
 677                     "some unknown error was encountered\n";
 678         }
 679     } else {
 680         return "Alert: unknown error encountered\n";
 681     }
 682 }
 683
 684 package CPAN::Prompt; use overload '""' => "as_string";
 685 use vars qw($prompt);
 686 $prompt = "cpan> ";
 687 $CPAN::CurrentCommandId ||= 0;
 688 sub new {
 689     bless {}, shift;
 690 }
 691 sub as_string {
 692     my $word = "cpan";
 693     unless ($CPAN::META->{LOCK}) {
 694         $word = "nolock_cpan";
 695     }
 696     if ($CPAN::Config->{commandnumber_in_prompt}) {
 697         sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
 698     } else {
 699         "$word> ";
 700     }
 701 }
 702
 703 package CPAN::URL; use overload '""' => "as_string", fallback => 1;
 704 # accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
 705 # planned are things like age or quality
 706 sub new {
 707     my($class,%args) = @_;
 708     bless {
 709            %args
 710           }, $class;
 711 }
 712 sub as_string {
 713     my($self) = @_;
 714     $self->text;
 715 }
 716 sub text {
 717     my($self,$set) = @_;
 718     if (defined $set) {
 719         $self->{TEXT} = $set;
 720     }
 721     $self->{TEXT};
 722 }
 723
 724 package CPAN::Distrostatus;
 725 use overload '""' => "as_string",
 726     fallback => 1;
 727 sub new {
 728     my($class,$arg) = @_;
 729     bless {
 730            TEXT => $arg,
 731            FAILED => substr($arg,0,2) eq "NO",
 732            COMMANDID => $CPAN::CurrentCommandId,
 733            TIME => time,
 734           }, $class;
 735 }
 736 sub commandid { shift->{COMMANDID} }
 737 sub failed { shift->{FAILED} }
 738 sub text {
 739     my($self,$set) = @_;
 740     if (defined $set) {
 741         $self->{TEXT} = $set;
 742     }
 743     $self->{TEXT};
 744 }
 745 sub as_string {
 746     my($self) = @_;
 747     $self->text;
 748 }
 749
 750 package CPAN::Shell;
 751 use strict;
 752 use vars qw(
 753             $ADVANCED_QUERY
 754             $AUTOLOAD
 755             $COLOR_REGISTERED
 756             $autoload_recursion
 757             $reload
 758             @ISA
 759            );
 760 @CPAN::Shell::ISA = qw(CPAN::Debug);
 761 $COLOR_REGISTERED ||= 0;
 762
 763 {
 764     $autoload_recursion   ||= 0;
 765
 766     #-> sub CPAN::Shell::AUTOLOAD ;
 767     sub AUTOLOAD {
 768         $autoload_recursion++;
 769         my($l) = $AUTOLOAD;
 770         my $class = shift(@_);
 771         # warn "autoload[$l] class[$class]";
 772         $l =~ s/.*:://;
 773         if ($CPAN::Signal) {
 774             warn "Refusing to autoload '$l' while signal pending";
 775             $autoload_recursion--;
 776             return;
 777         }
 778         if ($autoload_recursion > 1) {
 779             my $fullcommand = join " ", map { "'$_'" } $l, @_;
 780             warn "Refusing to autoload $fullcommand in recursion\n";
 781             $autoload_recursion--;
 782             return;
 783         }
 784         if ($l =~ /^w/) {
 785             # XXX needs to be reconsidered
 786             if ($CPAN::META->has_inst('CPAN::WAIT')) {
 787                 CPAN::WAIT->$l(@_);
 788             } else {
 789                 $CPAN::Frontend->mywarn(qq{
 790 Commands starting with "w" require CPAN::WAIT to be installed.
 791 Please consider installing CPAN::WAIT to use the fulltext index.
 792 For this you just need to type
 793     install CPAN::WAIT
 794 });
 795             }
 796         } else {
 797             $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
 798                                     qq{Type ? for help.
 799 });
 800         }
 801         $autoload_recursion--;
 802     }
 803 }
 804
 805 package CPAN;
 806 use strict;
 807
 808 $META ||= CPAN->new; # In case we re-eval ourselves we need the ||
 809
 810 # from here on only subs.
 811 ################################################################################
 812
 813 sub _perl_fingerprint {
 814     my($self,$other_fingerprint) = @_;
 815     my $dll = eval {OS2::DLLname()};
 816     my $mtime_dll = 0;
 817     if (defined $dll) {
 818         $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
 819     }
 820     my $mtime_perl = (-f $^X ? (stat(_))[9] : '-1');
 821     my $this_fingerprint = {
 822                             '$^X' => $^X,
 823                             sitearchexp => $Config::Config{sitearchexp},
 824                             'mtime_$^X' => $mtime_perl,
 825                             'mtime_dll' => $mtime_dll,
 826                            };
 827     if ($other_fingerprint) {
 828         if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
 829             $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
 830         }
 831         # mandatory keys since 1.88_57
 832         for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
 833             return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
 834         }
 835         return 1;
 836     } else {
 837         return $this_fingerprint;
 838     }
 839 }
 840
 841 sub suggest_myconfig () {
 842   SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
 843         $CPAN::Frontend->myprint("You don't seem to have a user ".
 844                                  "configuration (MyConfig.pm) yet.\n");
 845         my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
 846                                               "user configuration now? (Y/n)",
 847                                               "yes");
 848         if($new =~ m{^y}i) {
 849             CPAN::Shell->mkmyconfig();
 850             return &checklock;
 851         } else {
 852             $CPAN::Frontend->mydie("OK, giving up.");
 853         }
 854     }
 855 }
 856
 857 #-> sub CPAN::all_objects ;
 858 sub all_objects {
 859     my($mgr,$class) = @_;
 860     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
 861     CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
 862     CPAN::Index->reload;
 863     values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
 864 }
 865
 866 # Called by shell, not in batch mode. In batch mode I see no risk in
 867 # having many processes updating something as installations are
 868 # continually checked at runtime. In shell mode I suspect it is
 869 # unintentional to open more than one shell at a time
 870
 871 #-> sub CPAN::checklock ;
 872 sub checklock {
 873     my($self) = @_;
 874     my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
 875     if (-f $lockfile && -M _ > 0) {
 876         my $fh = FileHandle->new($lockfile) or
 877             $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
 878         my $otherpid  = <$fh>;
 879         my $otherhost = <$fh>;
 880         $fh->close;
 881         if (defined $otherpid && $otherpid) {
 882             chomp $otherpid;
 883         }
 884         if (defined $otherhost && $otherhost) {
 885             chomp $otherhost;
 886         }
 887         my $thishost  = hostname();
 888         if (defined $otherhost && defined $thishost &&
 889             $otherhost ne '' && $thishost ne '' &&
 890             $otherhost ne $thishost) {
 891             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
 892                                            "reports other host $otherhost and other ".
 893                                            "process $otherpid.\n".
 894                                            "Cannot proceed.\n"));
 895         } elsif ($RUN_DEGRADED) {
 896             $CPAN::Frontend->mywarn("Running in degraded mode (experimental)\n");
 897         } elsif (defined $otherpid && $otherpid) {
 898             return if $$ == $otherpid; # should never happen
 899             $CPAN::Frontend->mywarn(
 900                                     qq{
 901 There seems to be running another CPAN process (pid $otherpid).  Contacting...
 902 });
 903             if (kill 0, $otherpid) {
 904                 $CPAN::Frontend->mywarn(qq{Other job is running.\n});
 905                 my($ans) =
 906                     CPAN::Shell::colorable_makemaker_prompt
 907                         (qq{Shall I try to run in degraded }.
 908                          qq{mode? (Y/n)},"y");
 909                 if ($ans =~ /^y/i) {
 910                     $CPAN::Frontend->mywarn("Running in degraded mode (experimental).
 911 Please report if something unexpected happens\n");
 912                     $RUN_DEGRADED = 1;
 913                     for ($CPAN::Config) {
 914                         # XXX
 915                         # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
 916                         $_->{commandnumber_in_prompt} = 0; # visibility
 917                         $_->{histfile} = "";               # who should win otherwise?
 918                         $_->{cache_metadata} = 0;          # better would be a lock?
 919                         $_->{use_sqlite} = 0;              # better would be a write lock!
 920                     }
 921                 } else {
 922                     $CPAN::Frontend->mydie("
 923 You may want to kill the other job and delete the lockfile. On UNIX try:
 924     kill $otherpid
 925     rm $lockfile
 926 ");
 927                 }
 928             } elsif (-w $lockfile) {
 929                 my($ans) =
 930                     CPAN::Shell::colorable_makemaker_prompt
 931                         (qq{Other job not responding. Shall I overwrite }.
 932                          qq{the lockfile '$lockfile'? (Y/n)},"y");
 933                 $CPAN::Frontend->myexit("Ok, bye\n")
 934                     unless $ans =~ /^y/i;
 935             } else {
 936                 Carp::croak(
 937                             qq{Lockfile '$lockfile' not writeable by you. }.
 938                             qq{Cannot proceed.\n}.
 939                             qq{    On UNIX try:\n}.
 940                             qq{    rm '$lockfile'\n}.
 941                             qq{  and then rerun us.\n}
 942                            );
 943             }
 944         } else {
 945             $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
 946                                            "'$lockfile', please remove. Cannot proceed.\n"));
 947         }
 948     }
 949     my $dotcpan = $CPAN::Config->{cpan_home};
 950     eval { File::Path::mkpath($dotcpan);};
 951     if ($@) {
 952         # A special case at least for Jarkko.
 953         my $firsterror = $@;
 954         my $seconderror;
 955         my $symlinkcpan;
 956         if (-l $dotcpan) {
 957             $symlinkcpan = readlink $dotcpan;
 958             die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
 959             eval { File::Path::mkpath($symlinkcpan); };
 960             if ($@) {
 961                 $seconderror = $@;
 962             } else {
 963                 $CPAN::Frontend->mywarn(qq{
 964 Working directory $symlinkcpan created.
 965 });
 966             }
 967         }
 968         unless (-d $dotcpan) {
 969             my $mess = qq{
 970 Your configuration suggests "$dotcpan" as your
 971 CPAN.pm working directory. I could not create this directory due
 972 to this error: $firsterror\n};
 973             $mess .= qq{
 974 As "$dotcpan" is a symlink to "$symlinkcpan",
 975 I tried to create that, but I failed with this error: $seconderror
 976 } if $seconderror;
 977             $mess .= qq{
 978 Please make sure the directory exists and is writable.
 979 };
 980             $CPAN::Frontend->myprint($mess);
 981             return suggest_myconfig;
 982         }
 983     } # $@ after eval mkpath $dotcpan
 984     if (0) { # to test what happens when a race condition occurs
 985         for (reverse 1..10) {
 986             print $_, "\n";
 987             sleep 1;
 988         }
 989     }
 990     # locking
 991     if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
 992         my $fh;
 993         unless ($fh = FileHandle->new("+>>$lockfile")) {
 994             if ($! =~ /Permission/) {
 995                 $CPAN::Frontend->myprint(qq{
 996
 997 Your configuration suggests that CPAN.pm should use a working
 998 directory of
 999     $CPAN::Config->{cpan_home}
1000 Unfortunately we could not create the lock file
1001     $lockfile
1002 due to permission problems.
1003
1004 Please make sure that the configuration variable
1005     \$CPAN::Config->{cpan_home}
1006 points to a directory where you can write a .lock file. You can set
1007 this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
1008 \@INC path;
1009 });
1010                 return suggest_myconfig;
1011             }
1012         }
1013         my $sleep = 1;
1014         while (!flock $fh, LOCK_EX|LOCK_NB) {
1015             if ($sleep>10) {
1016                 $CPAN::Frontend->mydie("Giving up\n");
1017             }
1018             $CPAN::Frontend->mysleep($sleep++);
1019             $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
1020         }
1021
1022         seek $fh, 0, 0;
1023         truncate $fh, 0;
1024         $fh->print($$, "\n");
1025         $fh->print(hostname(), "\n");
1026         $self->{LOCK} = $lockfile;
1027         $self->{LOCKFH} = $fh;
1028     }
1029     $SIG{TERM} = sub {
1030         my $sig = shift;
1031         &cleanup;
1032         $CPAN::Frontend->mydie("Got SIG$sig, leaving");
1033     };
1034     $SIG{INT} = sub {
1035       # no blocks!!!
1036         my $sig = shift;
1037         &cleanup if $Signal;
1038         die "Got yet another signal" if $Signal > 1;
1039         $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
1040         $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
1041         $Signal++;
1042     };
1043
1044 #       From: Larry Wall <larry@wall.org>
1045 #       Subject: Re: deprecating SIGDIE
1046 #       To: perl5-porters@perl.org
1047 #       Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
1048 #
1049 #       The original intent of __DIE__ was only to allow you to substitute one
1050 #       kind of death for another on an application-wide basis without respect
1051 #       to whether you were in an eval or not.  As a global backstop, it should
1052 #       not be used any more lightly (or any more heavily :-) than class
1053 #       UNIVERSAL.  Any attempt to build a general exception model on it should
1054 #       be politely squashed.  Any bug that causes every eval {} to have to be
1055 #       modified should be not so politely squashed.
1056 #
1057 #       Those are my current opinions.  It is also my optinion that polite
1058 #       arguments degenerate to personal arguments far too frequently, and that
1059 #       when they do, it's because both people wanted it to, or at least didn't
1060 #       sufficiently want it not to.
1061 #
1062 #       Larry
1063
1064     # global backstop to cleanup if we should really die
1065     $SIG{__DIE__} = \&cleanup;
1066     $self->debug("Signal handler set.") if $CPAN::DEBUG;
1067 }
1068
1069 #-> sub CPAN::DESTROY ;
1070 sub DESTROY {
1071     &cleanup; # need an eval?
1072 }
1073
1074 #-> sub CPAN::anycwd ;
1075 sub anycwd () {
1076     my $getcwd;
1077     $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
1078     CPAN->$getcwd();
1079 }
1080
1081 #-> sub CPAN::cwd ;
1082 sub cwd {Cwd::cwd();}
1083
1084 #-> sub CPAN::getcwd ;
1085 sub getcwd {Cwd::getcwd();}
1086
1087 #-> sub CPAN::fastcwd ;
1088 sub fastcwd {Cwd::fastcwd();}
1089
1090 #-> sub CPAN::backtickcwd ;
1091 sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
1092
1093 #-> sub CPAN::find_perl ;
1094 sub find_perl {
1095     my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
1096     my $pwd  = $CPAN::iCwd = CPAN::anycwd();
1097     my $candidate = File::Spec->catfile($pwd,$^X);
1098     $perl ||= $candidate if MM->maybe_command($candidate);
1099
1100     unless ($perl) {
1101         my ($component,$perl_name);
1102       DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
1103             PATH_COMPONENT: foreach $component (File::Spec->path(),
1104                                                 $Config::Config{'binexp'}) {
1105                   next unless defined($component) && $component;
1106                   my($abs) = File::Spec->catfile($component,$perl_name);
1107                   if (MM->maybe_command($abs)) {
1108                       $perl = $abs;
1109                       last DIST_PERLNAME;
1110                   }
1111               }
1112           }
1113     }
1114
1115     return $perl;
1116 }
1117
1118
1119 #-> sub CPAN::exists ;
1120 sub exists {
1121     my($mgr,$class,$id) = @_;
1122     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
1123     CPAN::Index->reload;
1124     ### Carp::croak "exists called without class argument" unless $class;
1125     $id ||= "";
1126     $id =~ s/:+/::/g if $class eq "CPAN::Module";
1127     my $exists;
1128     if (CPAN::_sqlite_running) {
1129         $exists = (exists $META->{readonly}{$class}{$id} or
1130                    $CPAN::SQLite->set($class, $id));
1131     } else {
1132         $exists =  exists $META->{readonly}{$class}{$id};
1133     }
1134     $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1135 }
1136
1137 #-> sub CPAN::delete ;
1138 sub delete {
1139   my($mgr,$class,$id) = @_;
1140   delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
1141   delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
1142 }
1143
1144 #-> sub CPAN::has_usable
1145 # has_inst is sometimes too optimistic, we should replace it with this
1146 # has_usable whenever a case is given
1147 sub has_usable {
1148     my($self,$mod,$message) = @_;
1149     return 1 if $HAS_USABLE->{$mod};
1150     my $has_inst = $self->has_inst($mod,$message);
1151     return unless $has_inst;
1152     my $usable;
1153     $usable = {
1154                LWP => [ # we frequently had "Can't locate object
1155                         # method "new" via package "LWP::UserAgent" at
1156                         # (eval 69) line 2006
1157                        sub {require LWP},
1158                        sub {require LWP::UserAgent},
1159                        sub {require HTTP::Request},
1160                        sub {require URI::URL},
1161                       ],
1162                'Net::FTP' => [
1163                             sub {require Net::FTP},
1164                             sub {require Net::Config},
1165                            ],
1166                'File::HomeDir' => [
1167                                    sub {require File::HomeDir;
1168                                         unless (File::HomeDir::->VERSION >= 0.52){
1169                                             for ("Will not use File::HomeDir, need 0.52\n") {
1170                                                 $CPAN::Frontend->mywarn($_);
1171                                                 die $_;
1172                                             }
1173                                         }
1174                                     },
1175                                   ],
1176                'Archive::Tar' => [
1177                                   sub {require Archive::Tar;
1178                                        unless (Archive::Tar::->VERSION >= 1.00) {
1179                                             for ("Will not use Archive::Tar, need 1.00\n") {
1180                                                 $CPAN::Frontend->mywarn($_);
1181                                                 die $_;
1182                                             }
1183                                        }
1184                                   },
1185                                  ],
1186               };
1187     if ($usable->{$mod}) {
1188         for my $c (0..$#{$usable->{$mod}}) {
1189             my $code = $usable->{$mod}[$c];
1190             my $ret = eval { &$code() };
1191             $ret = "" unless defined $ret;
1192             if ($@) {
1193                 # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
1194                 return;
1195             }
1196         }
1197     }
1198     return $HAS_USABLE->{$mod} = 1;
1199 }
1200
1201 #-> sub CPAN::has_inst
1202 sub has_inst {
1203     my($self,$mod,$message) = @_;
1204     Carp::croak("CPAN->has_inst() called without an argument")
1205         unless defined $mod;
1206     my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
1207         keys %{$CPAN::Config->{dontload_hash}||{}},
1208             @{$CPAN::Config->{dontload_list}||[]};
1209     if (defined $message && $message eq "no"  # afair only used by Nox
1210         ||
1211         $dont{$mod}
1212        ) {
1213       $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
1214       return 0;
1215     }
1216     my $file = $mod;
1217     my $obj;
1218     $file =~ s|::|/|g;
1219     $file .= ".pm";
1220     if ($INC{$file}) {
1221         # checking %INC is wrong, because $INC{LWP} may be true
1222         # although $INC{"URI/URL.pm"} may have failed. But as
1223         # I really want to say "bla loaded OK", I have to somehow
1224         # cache results.
1225         ### warn "$file in %INC"; #debug
1226         return 1;
1227     } elsif (eval { require $file }) {
1228         # eval is good: if we haven't yet read the database it's
1229         # perfect and if we have installed the module in the meantime,
1230         # it tries again. The second require is only a NOOP returning
1231         # 1 if we had success, otherwise it's retrying
1232
1233         my $v = eval "\$$mod\::VERSION";
1234         $v = $v ? " (v$v)" : "";
1235         $CPAN::Frontend->myprint("CPAN: $mod loaded ok$v\n");
1236         if ($mod eq "CPAN::WAIT") {
1237             push @CPAN::Shell::ISA, 'CPAN::WAIT';
1238         }
1239         return 1;
1240     } elsif ($mod eq "Net::FTP") {
1241         $CPAN::Frontend->mywarn(qq{
1242   Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
1243   if you just type
1244       install Bundle::libnet
1245
1246 }) unless $Have_warned->{"Net::FTP"}++;
1247         $CPAN::Frontend->mysleep(3);
1248     } elsif ($mod eq "Digest::SHA"){
1249         if ($Have_warned->{"Digest::SHA"}++) {
1250             $CPAN::Frontend->myprint(qq{CPAN: checksum security checks disabled }.
1251                                      qq{because Digest::SHA not installed.\n});
1252         } else {
1253             $CPAN::Frontend->mywarn(qq{
1254   CPAN: checksum security checks disabled because Digest::SHA not installed.
1255   Please consider installing the Digest::SHA module.
1256
1257 });
1258             $CPAN::Frontend->mysleep(2);
1259         }
1260     } elsif ($mod eq "Module::Signature"){
1261         # NOT prefs_lookup, we are not a distro
1262         my $check_sigs = $CPAN::Config->{check_sigs};
1263         if (not $check_sigs) {
1264             # they do not want us:-(
1265         } elsif (not $Have_warned->{"Module::Signature"}++) {
1266             # No point in complaining unless the user can
1267             # reasonably install and use it.
1268             if (eval { require Crypt::OpenPGP; 1 } ||
1269                 (
1270                  defined $CPAN::Config->{'gpg'}
1271                  &&
1272                  $CPAN::Config->{'gpg'} =~ /\S/
1273                 )
1274                ) {
1275                 $CPAN::Frontend->mywarn(qq{
1276   CPAN: Module::Signature security checks disabled because Module::Signature
1277   not installed.  Please consider installing the Module::Signature module.
1278   You may also need to be able to connect over the Internet to the public
1279   keyservers like pgp.mit.edu (port 11371).
1280
1281 });
1282                 $CPAN::Frontend->mysleep(2);
1283             }
1284         }
1285     } else {
1286         delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
1287     }
1288     return 0;
1289 }
1290
1291 #-> sub CPAN::instance ;
1292 sub instance {
1293     my($mgr,$class,$id) = @_;
1294     CPAN::Index->reload;
1295     $id ||= "";
1296     # unsafe meta access, ok?
1297     return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
1298     $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
1299 }
1300
1301 #-> sub CPAN::new ;
1302 sub new {
1303     bless {}, shift;
1304 }
1305
1306 #-> sub CPAN::cleanup ;
1307 sub cleanup {
1308   # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
1309   local $SIG{__DIE__} = '';
1310   my($message) = @_;
1311   my $i = 0;
1312   my $ineval = 0;
1313   my($subroutine);
1314   while ((undef,undef,undef,$subroutine) = caller(++$i)) {
1315       $ineval = 1, last if
1316           $subroutine eq '(eval)';
1317   }
1318   return if $ineval && !$CPAN::End;
1319   return unless defined $META->{LOCK};
1320   return unless -f $META->{LOCK};
1321   $META->savehist;
1322   close $META->{LOCKFH};
1323   unlink $META->{LOCK};
1324   # require Carp;
1325   # Carp::cluck("DEBUGGING");
1326   if ( $CPAN::CONFIG_DIRTY ) {
1327       $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
1328   }
1329   $CPAN::Frontend->myprint("Lockfile removed.\n");
1330 }
1331
1332 #-> sub CPAN::readhist
1333 sub readhist {
1334     my($self,$term,$histfile) = @_;
1335     my($fh) = FileHandle->new;
1336     open $fh, "<$histfile" or last;
1337     local $/ = "\n";
1338     while (<$fh>) {
1339         chomp;
1340         $term->AddHistory($_);
1341     }
1342     close $fh;
1343 }
1344
1345 #-> sub CPAN::savehist
1346 sub savehist {
1347     my($self) = @_;
1348     my($histfile,$histsize);
1349     unless ($histfile = $CPAN::Config->{'histfile'}){
1350         $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
1351         return;
1352     }
1353     $histsize = $CPAN::Config->{'histsize'} || 100;
1354     if ($CPAN::term){
1355         unless ($CPAN::term->can("GetHistory")) {
1356             $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
1357             return;
1358         }
1359     } else {
1360         return;
1361     }
1362     my @h = $CPAN::term->GetHistory;
1363     splice @h, 0, @h-$histsize if @h>$histsize;
1364     my($fh) = FileHandle->new;
1365     open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
1366     local $\ = local $, = "\n";
1367     print $fh @h;
1368     close $fh;
1369 }
1370
1371 #-> sub CPAN::is_tested
1372 sub is_tested {
1373     my($self,$what,$when) = @_;
1374     unless ($what) {
1375         Carp::cluck("DEBUG: empty what");
1376         return;
1377     }
1378     $self->{is_tested}{$what} = $when;
1379 }
1380
1381 #-> sub CPAN::is_installed
1382 # unsets the is_tested flag: as soon as the thing is installed, it is
1383 # not needed in set_perl5lib anymore
1384 sub is_installed {
1385     my($self,$what) = @_;
1386     delete $self->{is_tested}{$what};
1387 }
1388
1389 sub _list_sorted_descending_is_tested {
1390     my($self) = @_;
1391     sort
1392         { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
1393             keys %{$self->{is_tested}}
1394 }
1395
1396 #-> sub CPAN::set_perl5lib
1397 sub set_perl5lib {
1398     my($self,$for) = @_;
1399     unless ($for) {
1400         (undef,undef,undef,$for) = caller(1);
1401         $for =~ s/.*://;
1402     }
1403     $self->{is_tested} ||= {};
1404     return unless %{$self->{is_tested}};
1405     my $env = $ENV{PERL5LIB};
1406     $env = $ENV{PERLLIB} unless defined $env;
1407     my @env;
1408     push @env, $env if defined $env and length $env;
1409     #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
1410     #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
1411
1412     my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
1413     if (@dirs < 12) {
1414         $CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB for '$for'\n");
1415     } elsif (@dirs < 24) {
1416         my @d = map {my $cp = $_;
1417                      $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
1418                      $cp
1419                  } @dirs;
1420         $CPAN::Frontend->myprint("Prepending @d to PERL5LIB; ".
1421                                  "%BUILDDIR%=$CPAN::Config->{build_dir} ".
1422                                  "for '$for'\n"
1423                                 );
1424     } else {
1425         my $cnt = keys %{$self->{is_tested}};
1426         $CPAN::Frontend->myprint("Prepending blib/arch and blib/lib of ".
1427                                  "$cnt build dirs to PERL5LIB; ".
1428                                  "for '$for'\n"
1429                                 );
1430     }
1431
1432     $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
1433 }
1434
1435 package CPAN::CacheMgr;
1436 use strict;
1437
1438 #-> sub CPAN::CacheMgr::as_string ;
1439 sub as_string {
1440     eval { require Data::Dumper };
1441     if ($@) {
1442         return shift->SUPER::as_string;
1443     } else {
1444         return Data::Dumper::Dumper(shift);
1445     }
1446 }
1447
1448 #-> sub CPAN::CacheMgr::cachesize ;
1449 sub cachesize {
1450     shift->{DU};
1451 }
1452
1453 #-> sub CPAN::CacheMgr::tidyup ;
1454 sub tidyup {
1455   my($self) = @_;
1456   return unless $CPAN::META->{LOCK};
1457   return unless -d $self->{ID};
1458   while ($self->{DU} > $self->{'MAX'} ) {
1459     my($toremove) = shift @{$self->{FIFO}};
1460     unless ($toremove =~ /\.yml$/) {
1461         $CPAN::Frontend->myprint(sprintf(
1462                                          "DEL(%.1f>%.1fMB): %s \n",
1463                                          $self->{DU},
1464                                          $self->{MAX},
1465                                          $toremove,
1466                                         )
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 $b <=> -M $a} @entries;
1503 }
1504
1505 #-> sub CPAN::CacheMgr::disk_usage ;
1506 sub disk_usage {
1507     my($self,$dir) = @_;
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     find(
1530          sub {
1531            $File::Find::prune++ if $CPAN::Signal;
1532            return if -l $_;
1533            if ($^O eq 'MacOS') {
1534              require Mac::Files;
1535              my $cat  = Mac::Files::FSpGetCatInfo($_);
1536              $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
1537            } else {
1538              if (-d _) {
1539                unless (-x _) {
1540                  unless (chmod 0755, $_) {
1541                    $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
1542                                            "the permission to change the permission; ".
1543                                            "can only partially estimate disk usage ".
1544                                            "of '$_'\n");
1545                    $CPAN::Frontend->mysleep(5);
1546                    return;
1547                  }
1548                }
1549              } else {
1550                $Du += (-s _);
1551              }
1552            }
1553          },
1554          $dir
1555         );
1556     return if $CPAN::Signal;
1557     $self->{SIZE}{$dir} = $Du/1024/1024;
1558     push @{$self->{FIFO}}, $dir;
1559     $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
1560     $self->{DU} += $Du/1024/1024;
1561     $self->{DU};
1562 }
1563
1564 #-> sub CPAN::CacheMgr::_clean_cache ;
1565 sub _clean_cache {
1566     my($self,$dir) = @_;
1567     return unless -e $dir;
1568     unless (File::Spec->canonpath(File::Basename::dirname($dir))
1569             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
1570         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
1571                                 "will not remove\n");
1572         $CPAN::Frontend->mysleep(5);
1573         return;
1574     }
1575     $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
1576         if $CPAN::DEBUG;
1577     File::Path::rmtree($dir);
1578     my $id_deleted = 0;
1579     if ($dir !~ /\.yml$/ && -f "$dir.yml") {
1580         my $yaml_module = CPAN::_yaml_module;
1581         if ($CPAN::META->has_inst($yaml_module)) {
1582             my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
1583             if ($@) {
1584                 $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
1585                 unlink "$dir.yml" or
1586                     $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
1587                 return;
1588             } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
1589                 $CPAN::META->delete("CPAN::Distribution", $id);
1590
1591                 # XXX we should restore the state NOW, otherise this
1592                 # distro does not exist until we read an index. BUG ALERT(?)
1593
1594                 # $CPAN::Frontend->mywarn (" +++\n");
1595                 $id_deleted++;
1596             }
1597         }
1598         unlink "$dir.yml"; # may fail
1599         unless ($id_deleted) {
1600             CPAN->debug("no distro found associated with '$dir'");
1601         }
1602     }
1603     $self->{DU} -= $self->{SIZE}{$dir};
1604     delete $self->{SIZE}{$dir};
1605 }
1606
1607 #-> sub CPAN::CacheMgr::new ;
1608 sub new {
1609     my $class = shift;
1610     my $time = time;
1611     my($debug,$t2);
1612     $debug = "";
1613     my $self = {
1614                 ID => $CPAN::Config->{build_dir},
1615                 MAX => $CPAN::Config->{'build_cache'},
1616                 SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
1617                 DU => 0
1618                };
1619     File::Path::mkpath($self->{ID});
1620     my $dh = DirHandle->new($self->{ID});
1621     bless $self, $class;
1622     $self->scan_cache;
1623     $t2 = time;
1624     $debug .= "timing of CacheMgr->new: ".($t2 - $time);
1625     $time = $t2;
1626     CPAN->debug($debug) if $CPAN::DEBUG;
1627     $self;
1628 }
1629
1630 #-> sub CPAN::CacheMgr::scan_cache ;
1631 sub scan_cache {
1632     my $self = shift;
1633     return if $self->{SCAN} eq 'never';
1634     $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
1635         unless $self->{SCAN} eq 'atstart';
1636     return unless $CPAN::META->{LOCK};
1637     $CPAN::Frontend->myprint(
1638                              sprintf("Scanning cache %s for sizes\n",
1639                                      $self->{ID}));
1640     my $e;
1641     my @entries = grep { !/^\.\.?$/ } $self->entries($self->{ID});
1642     my $i = 0;
1643     my $painted = 0;
1644     for $e (@entries) {
1645         # next if $e eq ".." || $e eq ".";
1646         $self->disk_usage($e);
1647         $i++;
1648         while (($painted/76) < ($i/@entries)) {
1649             $CPAN::Frontend->myprint(".");
1650             $painted++;
1651         }
1652         return if $CPAN::Signal;
1653     }
1654     $CPAN::Frontend->myprint("DONE\n");
1655     $self->tidyup;
1656 }
1657
1658 package CPAN::Shell;
1659 use strict;
1660
1661 #-> sub CPAN::Shell::h ;
1662 sub h {
1663     my($class,$about) = @_;
1664     if (defined $about) {
1665         $CPAN::Frontend->myprint("Detailed help not yet implemented\n");
1666     } else {
1667         my $filler = " " x (80 - 28 - length($CPAN::VERSION));
1668         $CPAN::Frontend->myprint(qq{
1669 Display Information $filler (ver $CPAN::VERSION)
1670  command  argument          description
1671  a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
1672  i        WORD or /REGEXP/  about any of the above
1673  ls       AUTHOR or GLOB    about files in the author's directory
1674     (with WORD being a module, bundle or author name or a distribution
1675     name of the form AUTHOR/DISTRIBUTION)
1676
1677 Download, Test, Make, Install...
1678  get      download                     clean    make clean
1679  make     make (implies get)           look     open subshell in dist directory
1680  test     make test (implies make)     readme   display these README files
1681  install  make install (implies test)  perldoc  display POD documentation
1682
1683 Upgrade
1684  r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all modules
1685  upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules
1686
1687 Pragmas
1688  force  CMD    try hard to do command  fforce CMD    try harder
1689  notest CMD    skip testing
1690
1691 Other
1692  h,?           display this menu       ! perl-code   eval a perl command
1693  o conf [opt]  set and query options   q             quit the cpan shell
1694  reload cpan   load CPAN.pm again      reload index  load newer indices
1695  autobundle    Snapshot                recent        latest CPAN uploads});
1696 }
1697 }
1698
1699 *help = \&h;
1700
1701 #-> sub CPAN::Shell::a ;
1702 sub a {
1703   my($self,@arg) = @_;
1704   # authors are always UPPERCASE
1705   for (@arg) {
1706     $_ = uc $_ unless /=/;
1707   }
1708   $CPAN::Frontend->myprint($self->format_result('Author',@arg));
1709 }
1710
1711 #-> sub CPAN::Shell::globls ;
1712 sub globls {
1713     my($self,$s,$pragmas) = @_;
1714     # ls is really very different, but we had it once as an ordinary
1715     # command in the Shell (upto rev. 321) and we could not handle
1716     # force well then
1717     my(@accept,@preexpand);
1718     if ($s =~ /[\*\?\/]/) {
1719         if ($CPAN::META->has_inst("Text::Glob")) {
1720             if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
1721                 my $rau = Text::Glob::glob_to_regex(uc $au);
1722                 CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
1723                       if $CPAN::DEBUG;
1724                 push @preexpand, map { $_->id . "/" . $pathglob }
1725                     CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
1726             } else {
1727                 my $rau = Text::Glob::glob_to_regex(uc $s);
1728                 push @preexpand, map { $_->id }
1729                     CPAN::Shell->expand_by_method('CPAN::Author',
1730                                                   ['id'],
1731                                                   "/$rau/");
1732             }
1733         } else {
1734             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
1735         }
1736     } else {
1737         push @preexpand, uc $s;
1738     }
1739     for (@preexpand) {
1740         unless (/^[A-Z0-9\-]+(\/|$)/i) {
1741             $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
1742             next;
1743         }
1744         push @accept, $_;
1745     }
1746     my $silent = @accept>1;
1747     my $last_alpha = "";
1748     my @results;
1749     for my $a (@accept){
1750         my($author,$pathglob);
1751         if ($a =~ m|(.*?)/(.*)|) {
1752             my $a2 = $1;
1753             $pathglob = $2;
1754             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1755                                                     ['id'],
1756                                                     $a2)
1757                 or $CPAN::Frontend->mydie("No author found for $a2\n");
1758         } else {
1759             $author = CPAN::Shell->expand_by_method('CPAN::Author',
1760                                                     ['id'],
1761                                                     $a)
1762                 or $CPAN::Frontend->mydie("No author found for $a\n");
1763         }
1764         if ($silent) {
1765             my $alpha = substr $author->id, 0, 1;
1766             my $ad;
1767             if ($alpha eq $last_alpha) {
1768                 $ad = "";
1769             } else {
1770                 $ad = "[$alpha]";
1771                 $last_alpha = $alpha;
1772             }
1773             $CPAN::Frontend->myprint($ad);
1774         }
1775         for my $pragma (@$pragmas) {
1776             if ($author->can($pragma)) {
1777                 $author->$pragma();
1778             }
1779         }
1780         push @results, $author->ls($pathglob,$silent); # silent if
1781                                                        # more than one
1782                                                        # author
1783         for my $pragma (@$pragmas) {
1784             my $unpragma = "un$pragma";
1785             if ($author->can($unpragma)) {
1786                 $author->$unpragma();
1787             }
1788         }
1789     }
1790     @results;
1791 }
1792
1793 #-> sub CPAN::Shell::local_bundles ;
1794 sub local_bundles {
1795     my($self,@which) = @_;
1796     my($incdir,$bdir,$dh);
1797     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
1798         my @bbase = "Bundle";
1799         while (my $bbase = shift @bbase) {
1800             $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
1801             CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
1802             if ($dh = DirHandle->new($bdir)) { # may fail
1803                 my($entry);
1804                 for $entry ($dh->read) {
1805                     next if $entry =~ /^\./;
1806                     next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
1807                     if (-d File::Spec->catdir($bdir,$entry)){
1808                         push @bbase, "$bbase\::$entry";
1809                     } else {
1810                         next unless $entry =~ s/\.pm(?!\n)\Z//;
1811                         $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
1812                     }
1813                 }
1814             }
1815         }
1816     }
1817 }
1818
1819 #-> sub CPAN::Shell::b ;
1820 sub b {
1821     my($self,@which) = @_;
1822     CPAN->debug("which[@which]") if $CPAN::DEBUG;
1823     $self->local_bundles;
1824     $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
1825 }
1826
1827 #-> sub CPAN::Shell::d ;
1828 sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}
1829
1830 #-> sub CPAN::Shell::m ;
1831 sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
1832     my $self = shift;
1833     $CPAN::Frontend->myprint($self->format_result('Module',@_));
1834 }
1835
1836 #-> sub CPAN::Shell::i ;
1837 sub i {
1838     my($self) = shift;
1839     my(@args) = @_;
1840     @args = '/./' unless @args;
1841     my(@result);
1842     for my $type (qw/Bundle Distribution Module/) {
1843         push @result, $self->expand($type,@args);
1844     }
1845     # Authors are always uppercase.
1846     push @result, $self->expand("Author", map { uc $_ } @args);
1847
1848     my $result = @result == 1 ?
1849         $result[0]->as_string :
1850             @result == 0 ?
1851                 "No objects found of any type for argument @args\n" :
1852                     join("",
1853                          (map {$_->as_glimpse} @result),
1854                          scalar @result, " items found\n",
1855                         );
1856     $CPAN::Frontend->myprint($result);
1857 }
1858
1859 #-> sub CPAN::Shell::o ;
1860
1861 # CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
1862 # conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
1863 # probably have been called 'set' and 'o debug' maybe 'set debug' or
1864 # 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
1865 sub o {
1866     my($self,$o_type,@o_what) = @_;
1867     $o_type ||= "";
1868     CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
1869     if ($o_type eq 'conf') {
1870         if (!@o_what) { # print all things, "o conf"
1871             my($k,$v);
1872             $CPAN::Frontend->myprint("\$CPAN::Config options from ");
1873             my @from;
1874             if (exists $INC{'CPAN/Config.pm'}) {
1875                 push @from, $INC{'CPAN/Config.pm'};
1876             }
1877             if (exists $INC{'CPAN/MyConfig.pm'}) {
1878                 push @from, $INC{'CPAN/MyConfig.pm'};
1879             }
1880             $CPAN::Frontend->myprint(join " and ", map {"'$_'"} @from);
1881             $CPAN::Frontend->myprint(":\n");
1882             for $k (sort keys %CPAN::HandleConfig::can) {
1883                 $v = $CPAN::HandleConfig::can{$k};
1884                 $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
1885             }
1886             $CPAN::Frontend->myprint("\n");
1887             for $k (sort keys %$CPAN::Config) {
1888                 CPAN::HandleConfig->prettyprint($k);
1889             }
1890             $CPAN::Frontend->myprint("\n");
1891         } else {
1892             if (CPAN::HandleConfig->edit(@o_what)) {
1893             } else {
1894                 $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
1895                                          qq{items\n\n});
1896             }
1897         }
1898     } elsif ($o_type eq 'debug') {
1899         my(%valid);
1900         @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
1901         if (@o_what) {
1902             while (@o_what) {
1903                 my($what) = shift @o_what;
1904                 if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
1905                     $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
1906                     next;
1907                 }
1908                 if ( exists $CPAN::DEBUG{$what} ) {
1909                     $CPAN::DEBUG |= $CPAN::DEBUG{$what};
1910                 } elsif ($what =~ /^\d/) {
1911                     $CPAN::DEBUG = $what;
1912                 } elsif (lc $what eq 'all') {
1913                     my($max) = 0;
1914                     for (values %CPAN::DEBUG) {
1915                         $max += $_;
1916                     }
1917                     $CPAN::DEBUG = $max;
1918                 } else {
1919                     my($known) = 0;
1920                     for (keys %CPAN::DEBUG) {
1921                         next unless lc($_) eq lc($what);
1922                         $CPAN::DEBUG |= $CPAN::DEBUG{$_};
1923                         $known = 1;
1924                     }
1925                     $CPAN::Frontend->myprint("unknown argument [$what]\n")
1926                         unless $known;
1927                 }
1928             }
1929         } else {
1930           my $raw = "Valid options for debug are ".
1931               join(", ",sort(keys %CPAN::DEBUG), 'all').
1932                   qq{ or a number. Completion works on the options. }.
1933                       qq{Case is ignored.};
1934           require Text::Wrap;
1935           $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
1936           $CPAN::Frontend->myprint("\n\n");
1937         }
1938         if ($CPAN::DEBUG) {
1939             $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
1940             my($k,$v);
1941             for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
1942                 $v = $CPAN::DEBUG{$k};
1943                 $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
1944                     if $v & $CPAN::DEBUG;
1945             }
1946         } else {
1947             $CPAN::Frontend->myprint("Debugging turned off completely.\n");
1948         }
1949     } else {
1950         $CPAN::Frontend->myprint(qq{
1951 Known options:
1952   conf    set or get configuration variables
1953   debug   set or get debugging options
1954 });
1955     }
1956 }
1957
1958 # CPAN::Shell::paintdots_onreload
1959 sub paintdots_onreload {
1960     my($ref) = shift;
1961     sub {
1962         if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
1963             my($subr) = $1;
1964             ++$$ref;
1965             local($|) = 1;
1966             # $CPAN::Frontend->myprint(".($subr)");
1967             $CPAN::Frontend->myprint(".");
1968             if ($subr =~ /\bshell\b/i) {
1969                 # warn "debug[$_[0]]";
1970
1971                 # It would be nice if we could detect that a
1972                 # subroutine has actually changed, but for now we
1973                 # practically always set the GOTOSHELL global
1974
1975                 $CPAN::GOTOSHELL=1;
1976             }
1977             return;
1978         }
1979         warn @_;
1980     };
1981 }
1982
1983 #-> sub CPAN::Shell::hosts ;
1984 sub hosts {
1985     my($self) = @_;
1986     my $fullstats = CPAN::FTP->_ftp_statistics();
1987     my $history = $fullstats->{history} || [];
1988     my %S; # statistics
1989     while (my $last = pop @$history) {
1990         my $attempts = $last->{attempts} or next;
1991         my $start;
1992         if (@$attempts) {
1993             $start = $attempts->[-1]{start};
1994             if ($#$attempts > 0) {
1995                 for my $i (0..$#$attempts-1) {
1996                     my $url = $attempts->[$i]{url} or next;
1997                     $S{no}{$url}++;
1998                 }
1999             }
2000         } else {
2001             $start = $last->{start};
2002         }
2003         next unless $last->{thesiteurl}; # C-C? bad filenames?
2004         $S{start} = $start;
2005         $S{end} ||= $last->{end};
2006         my $dltime = $last->{end} - $start;
2007         my $dlsize = $last->{filesize} || 0;
2008         my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
2009         my $s = $S{ok}{$url} ||= {};
2010         $s->{n}++;
2011         $s->{dlsize} ||= 0;
2012         $s->{dlsize} += $dlsize/1024;
2013         $s->{dltime} ||= 0;
2014         $s->{dltime} += $dltime;
2015     }
2016     my $res;
2017     for my $url (keys %{$S{ok}}) {
2018         next if $S{ok}{$url}{dltime} == 0; # div by zero
2019         push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
2020                              $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
2021                              $url,
2022                             ];
2023     }
2024     for my $url (keys %{$S{no}}) {
2025         push @{$res->{no}}, [$S{no}{$url},
2026                              $url,
2027                             ];
2028     }
2029     my $R = ""; # report
2030     if ($S{start} && $S{end}) {
2031         $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
2032         $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
2033     }
2034     if ($res->{ok} && @{$res->{ok}}) {
2035         $R .= sprintf "\nSuccessful downloads:
2036    N       kB  secs      kB/s url\n";
2037         my $i = 20;
2038         for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
2039             $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
2040             last if --$i<=0;
2041         }
2042     }
2043     if ($res->{no} && @{$res->{no}}) {
2044         $R .= sprintf "\nUnsuccessful downloads:\n";
2045         my $i = 20;
2046         for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
2047             $R .= sprintf "%4d %s\n", @$_;
2048             last if --$i<=0;
2049         }
2050     }
2051     $CPAN::Frontend->myprint($R);
2052 }
2053
2054 #-> sub CPAN::Shell::reload ;
2055 sub reload {
2056     my($self,$command,@arg) = @_;
2057     $command ||= "";
2058     $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
2059     if ($command =~ /^cpan$/i) {
2060         my $redef = 0;
2061         chdir $CPAN::iCwd if $CPAN::iCwd; # may fail
2062         my $failed;
2063         my @relo = (
2064                     "CPAN.pm",
2065                     "CPAN/Debug.pm",
2066                     "CPAN/FirstTime.pm",
2067                     "CPAN/HandleConfig.pm",
2068                     "CPAN/Kwalify.pm",
2069                     "CPAN/Queue.pm",
2070                     "CPAN/Reporter.pm",
2071                     "CPAN/SQLite.pm",
2072                     "CPAN/Tarzip.pm",
2073                     "CPAN/Version.pm",
2074                    );
2075       MFILE: for my $f (@relo) {
2076             next unless exists $INC{$f};
2077             my $p = $f;
2078             $p =~ s/\.pm$//;
2079             $p =~ s|/|::|g;
2080             $CPAN::Frontend->myprint("($p");
2081             local($SIG{__WARN__}) = paintdots_onreload(\$redef);
2082             $self->_reload_this($f) or $failed++;
2083             my $v = eval "$p\::->VERSION";
2084             $CPAN::Frontend->myprint("v$v)");
2085         }
2086         $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
2087         if ($failed) {
2088             my $errors = $failed == 1 ? "error" : "errors";
2089             $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
2090                                     "this session.\n");
2091         }
2092     } elsif ($command =~ /^index$/i) {
2093       CPAN::Index->force_reload;
2094     } else {
2095       $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
2096 index    re-reads the index files\n});
2097     }
2098 }
2099
2100 # reload means only load again what we have loaded before
2101 #-> sub CPAN::Shell::_reload_this ;
2102 sub _reload_this {
2103     my($self,$f,$args) = @_;
2104     CPAN->debug("f[$f]") if $CPAN::DEBUG;
2105     return 1 unless $INC{$f}; # we never loaded this, so we do not
2106                               # reload but say OK
2107     my $pwd = CPAN::anycwd();
2108     CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
2109     my($file);
2110     for my $inc (@INC) {
2111         $file = File::Spec->catfile($inc,split /\//, $f);
2112         last if -f $file;
2113         $file = "";
2114     }
2115     CPAN->debug("file[$file]") if $CPAN::DEBUG;
2116     my @inc = @INC;
2117     unless ($file && -f $file) {
2118         # this thingie is not in the INC path, maybe CPAN/MyConfig.pm?
2119         $file = $INC{$f};
2120         unless (CPAN->has_inst("File::Basename")) {
2121             @inc = File::Basename::dirname($file);
2122         } else {
2123             # do we ever need this?
2124             @inc = substr($file,0,-length($f)-1); # bring in back to me!
2125         }
2126     }
2127     CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
2128     unless (-f $file) {
2129         $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
2130         return;
2131     }
2132     my $mtime = (stat $file)[9];
2133     $reload->{$f} ||= $^T;
2134     my $must_reload = $mtime > $reload->{$f};
2135     $args ||= {};
2136     $must_reload ||= $args->{reloforce};
2137     if ($must_reload) {
2138         my $fh = FileHandle->new($file) or
2139             $CPAN::Frontend->mydie("Could not open $file: $!");
2140         local($/);
2141         local $^W = 1;
2142         my $content = <$fh>;
2143         CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
2144             if $CPAN::DEBUG;
2145         delete $INC{$f};
2146         local @INC = @inc;
2147         eval "require '$f'";
2148         if ($@){
2149             warn $@;
2150             return;
2151         }
2152         $reload->{$f} = time;
2153     } else {
2154         $CPAN::Frontend->myprint("__unchanged__");
2155     }
2156     return 1;
2157 }
2158
2159 #-> sub CPAN::Shell::mkmyconfig ;
2160 sub mkmyconfig {
2161     my($self, $cpanpm, %args) = @_;
2162     require CPAN::FirstTime;
2163     my $home = CPAN::HandleConfig::home;
2164     $cpanpm = $INC{'CPAN/MyConfig.pm'} ||
2165         File::Spec->catfile(split /\//, "$home/.cpan/CPAN/MyConfig.pm");
2166     File::Path::mkpath(File::Basename::dirname($cpanpm)) unless -e $cpanpm;
2167     CPAN::HandleConfig::require_myconfig_or_config;
2168     $CPAN::Config ||= {};
2169     $CPAN::Config = {
2170         %$CPAN::Config,
2171         build_dir           =>  undef,
2172         cpan_home           =>  undef,
2173         keep_source_where   =>  undef,
2174         histfile            =>  undef,
2175     };
2176     CPAN::FirstTime::init($cpanpm, %args);
2177 }
2178
2179 #-> sub CPAN::Shell::_binary_extensions ;
2180 sub _binary_extensions {
2181     my($self) = shift @_;
2182     my(@result,$module,%seen,%need,$headerdone);
2183     for $module ($self->expand('Module','/./')) {
2184         my $file  = $module->cpan_file;
2185         next if $file eq "N/A";
2186         next if $file =~ /^Contact Author/;
2187         my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
2188         next if $dist->isa_perl;
2189         next unless $module->xs_file;
2190         local($|) = 1;
2191         $CPAN::Frontend->myprint(".");
2192         push @result, $module;
2193     }
2194 #    print join " | ", @result;
2195     $CPAN::Frontend->myprint("\n");
2196     return @result;
2197 }
2198
2199 #-> sub CPAN::Shell::recompile ;
2200 sub recompile {
2201     my($self) = shift @_;
2202     my($module,@module,$cpan_file,%dist);
2203     @module = $self->_binary_extensions();
2204     for $module (@module){  # we force now and compile later, so we
2205                             # don't do it twice
2206         $cpan_file = $module->cpan_file;
2207         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2208         $pack->force; #
2209         $dist{$cpan_file}++;
2210     }
2211     for $cpan_file (sort keys %dist) {
2212         $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
2213         my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
2214         $pack->install;
2215         $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
2216                            # stop a package from recompiling,
2217                            # e.g. IO-1.12 when we have perl5.003_10
2218     }
2219 }
2220
2221 #-> sub CPAN::Shell::scripts ;
2222 sub scripts {
2223     my($self, $arg) = @_;
2224     $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");
2225
2226     for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
2227         unless ($CPAN::META->has_inst($req)) {
2228             $CPAN::Frontend->mywarn("  $req not available\n");
2229         }
2230     }
2231     my $p = HTML::LinkExtor->new();
2232     my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
2233     unless (-f $indexfile) {
2234         $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
2235     }
2236     $p->parse_file($indexfile);
2237     my @hrefs;
2238     my $qrarg;
2239     if ($arg =~ s|^/(.+)/$|$1|) {
2240         $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
2241     }
2242     for my $l ($p->links) {
2243         my $tag = shift @$l;
2244         next unless $tag eq "a";
2245         my %att = @$l;
2246         my $href = $att{href};
2247         next unless $href =~ s|^\.\./authors/id/./../||;
2248         if ($arg) {
2249             if ($qrarg) {
2250                 if ($href =~ $qrarg) {
2251                     push @hrefs, $href;
2252                 }
2253             } else {
2254                 if ($href =~ /\Q$arg\E/) {
2255                     push @hrefs, $href;
2256                 }
2257             }
2258         } else {
2259             push @hrefs, $href;
2260         }
2261     }
2262     # now filter for the latest version if there is more than one of a name
2263     my %stems;
2264     for (sort @hrefs) {
2265         my $href = $_;
2266         s/-v?\d.*//;
2267         my $stem = $_;
2268         $stems{$stem} ||= [];
2269         push @{$stems{$stem}}, $href;
2270     }
2271     for (sort keys %stems) {
2272         my $highest;
2273         if (@{$stems{$_}} > 1) {
2274             $highest = List::Util::reduce {
2275                 Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
2276               } @{$stems{$_}};
2277         } else {
2278             $highest = $stems{$_}[0];
2279         }
2280         $CPAN::Frontend->myprint("$highest\n");
2281     }
2282 }
2283
2284 #-> sub CPAN::Shell::report ;
2285 sub report {
2286     my($self,@args) = @_;
2287     unless ($CPAN::META->has_inst("CPAN::Reporter")) {
2288         $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
2289     }
2290     local $CPAN::Config->{test_report} = 1;
2291     $self->force("test",@args); # force is there so that the test be
2292                                 # re-run (as documented)
2293 }
2294
2295 # compare with is_tested
2296 #-> sub CPAN::Shell::install_tested
2297 sub install_tested {
2298     my($self,@some) = @_;
2299     $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
2300         return if @some;
2301     CPAN::Index->reload;
2302
2303     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2304         my $yaml = "$b.yml";
2305         unless (-f $yaml){
2306             $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
2307             next;
2308         }
2309         my $yaml_content = CPAN->_yaml_loadfile($yaml);
2310         my $id = $yaml_content->[0]{distribution}{ID};
2311         unless ($id){
2312             $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
2313             next;
2314         }
2315         my $do = CPAN::Shell->expandany($id);
2316         unless ($do){
2317             $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
2318             next;
2319         }
2320         unless ($do->{build_dir}) {
2321             $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
2322             next;
2323         }
2324         unless ($do->{build_dir} eq $b) {
2325             $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
2326             next;
2327         }
2328         push @some, $do;
2329     }
2330
2331     $CPAN::Frontend->mywarn("No tested distributions found.\n"),
2332         return unless @some;
2333
2334     @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
2335     $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
2336         return unless @some;
2337
2338     # @some = grep { not $_->uptodate } @some;
2339     # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
2340     #     return unless @some;
2341
2342     CPAN->debug("some[@some]");
2343     for my $d (@some) {
2344         my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
2345         $CPAN::Frontend->myprint("install_tested: Running for $id\n");
2346         $CPAN::Frontend->mysleep(1);
2347         $self->install($d);
2348     }
2349 }
2350
2351 #-> sub CPAN::Shell::upgrade ;
2352 sub upgrade {
2353     my($self,@args) = @_;
2354     $self->install($self->r(@args));
2355 }
2356
2357 #-> sub CPAN::Shell::_u_r_common ;
2358 sub _u_r_common {
2359     my($self) = shift @_;
2360     my($what) = shift @_;
2361     CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
2362     Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
2363           $what && $what =~ /^[aru]$/;
2364     my(@args) = @_;
2365     @args = '/./' unless @args;
2366     my(@result,$module,%seen,%need,$headerdone,
2367        $version_undefs,$version_zeroes);
2368     $version_undefs = $version_zeroes = 0;
2369     my $sprintf = "%s%-25s%s %9s %9s  %s\n";
2370     my @expand = $self->expand('Module',@args);
2371     my $expand = scalar @expand;
2372     if (0) { # Looks like noise to me, was very useful for debugging
2373              # for metadata cache
2374         $CPAN::Frontend->myprint(sprintf "%d matches in the database\n", $expand);
2375     }
2376   MODULE: for $module (@expand) {
2377         my $file  = $module->cpan_file;
2378         next MODULE unless defined $file; # ??
2379         $file =~ s|^./../||;
2380         my($latest) = $module->cpan_version;
2381         my($inst_file) = $module->inst_file;
2382         my($have);
2383         return if $CPAN::Signal;
2384         if ($inst_file){
2385             if ($what eq "a") {
2386                 $have = $module->inst_version;
2387             } elsif ($what eq "r") {
2388                 $have = $module->inst_version;
2389                 local($^W) = 0;
2390                 if ($have eq "undef"){
2391                     $version_undefs++;
2392                 } elsif ($have == 0){
2393                     $version_zeroes++;
2394                 }
2395                 next MODULE unless CPAN::Version->vgt($latest, $have);
2396 # to be pedantic we should probably say:
2397 #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
2398 # to catch the case where CPAN has a version 0 and we have a version undef
2399             } elsif ($what eq "u") {
2400                 next MODULE;
2401             }
2402         } else {
2403             if ($what eq "a") {
2404                 next MODULE;
2405             } elsif ($what eq "r") {
2406                 next MODULE;
2407             } elsif ($what eq "u") {
2408                 $have = "-";
2409             }
2410         }
2411         return if $CPAN::Signal; # this is sometimes lengthy
2412         $seen{$file} ||= 0;
2413         if ($what eq "a") {
2414             push @result, sprintf "%s %s\n", $module->id, $have;
2415         } elsif ($what eq "r") {
2416             push @result, $module->id;
2417             next MODULE if $seen{$file}++;
2418         } elsif ($what eq "u") {
2419             push @result, $module->id;
2420             next MODULE if $seen{$file}++;
2421             next MODULE if $file =~ /^Contact/;
2422         }
2423         unless ($headerdone++){
2424             $CPAN::Frontend->myprint("\n");
2425             $CPAN::Frontend->myprint(sprintf(
2426                                              $sprintf,
2427                                              "",
2428                                              "Package namespace",
2429                                              "",
2430                                              "installed",
2431                                              "latest",
2432                                              "in CPAN file"
2433                                             ));
2434         }
2435         my $color_on = "";
2436         my $color_off = "";
2437         if (
2438             $COLOR_REGISTERED
2439             &&
2440             $CPAN::META->has_inst("Term::ANSIColor")
2441             &&
2442             $module->description
2443            ) {
2444             $color_on = Term::ANSIColor::color("green");
2445             $color_off = Term::ANSIColor::color("reset");
2446         }
2447         $CPAN::Frontend->myprint(sprintf $sprintf,
2448                                  $color_on,
2449                                  $module->id,
2450                                  $color_off,
2451                                  $have,
2452                                  $latest,
2453                                  $file);
2454         $need{$module->id}++;
2455     }
2456     unless (%need) {
2457         if ($what eq "u") {
2458             $CPAN::Frontend->myprint("No modules found for @args\n");
2459         } elsif ($what eq "r") {
2460             $CPAN::Frontend->myprint("All modules are up to date for @args\n");
2461         }
2462     }
2463     if ($what eq "r") {
2464         if ($version_zeroes) {
2465             my $s_has = $version_zeroes > 1 ? "s have" : " has";
2466             $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
2467                 qq{a version number of 0\n});
2468         }
2469         if ($version_undefs) {
2470             my $s_has = $version_undefs > 1 ? "s have" : " has";
2471             $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
2472                 qq{parseable version number\n});
2473         }
2474     }
2475     @result;
2476 }
2477
2478 #-> sub CPAN::Shell::r ;
2479 sub r {
2480     shift->_u_r_common("r",@_);
2481 }
2482
2483 #-> sub CPAN::Shell::u ;
2484 sub u {
2485     shift->_u_r_common("u",@_);
2486 }
2487
2488 #-> sub CPAN::Shell::failed ;
2489 sub failed {
2490     my($self,$only_id,$silent) = @_;
2491     my @failed;
2492   DIST: for my $d ($CPAN::META->all_objects("CPAN::Distribution")) {
2493         my $failed = "";
2494       NAY: for my $nosayer ( # order matters!
2495                             "unwrapped",
2496                             "writemakefile",
2497                             "signature_verify",
2498                             "make",
2499                             "make_test",
2500                             "install",
2501                             "make_clean",
2502                            ) {
2503             next unless exists $d->{$nosayer};
2504             next unless defined $d->{$nosayer};
2505             next unless (
2506                          UNIVERSAL::can($d->{$nosayer},"failed") ?
2507                          $d->{$nosayer}->failed :
2508                          $d->{$nosayer} =~ /^NO/
2509                         );
2510             next NAY if $only_id && $only_id != (
2511                                                  UNIVERSAL::can($d->{$nosayer},"commandid")
2512                                                  ?
2513                                                  $d->{$nosayer}->commandid
2514                                                  :
2515                                                  $CPAN::CurrentCommandId
2516                                                 );
2517             $failed = $nosayer;
2518             last;
2519         }
2520         next DIST unless $failed;
2521         my $id = $d->id;
2522         $id =~ s|^./../||;
2523         #$print .= sprintf(
2524         #                  "  %-45s: %s %s\n",
2525         push @failed,
2526             (
2527              UNIVERSAL::can($d->{$failed},"failed") ?
2528              [
2529               $d->{$failed}->commandid,
2530               $id,
2531               $failed,
2532               $d->{$failed}->text,
2533               $d->{$failed}{TIME}||0,
2534              ] :
2535              [
2536               1,
2537               $id,
2538               $failed,
2539               $d->{$failed},
2540               0,
2541              ]
2542             );
2543     }
2544     my $scope;
2545     if ($only_id) {
2546         $scope = "this command";
2547     } elsif ($CPAN::Index::HAVE_REANIMATED) {
2548         $scope = "this or a previous session";
2549         # it might be nice to have a section for previous session and
2550         # a second for this
2551     } else {
2552         $scope = "this session";
2553     }
2554     if (@failed) {
2555         my $print;
2556         my $debug = 0;
2557         if ($debug) {
2558             $print = join "",
2559                 map { sprintf "%5d %-45s: %s %s\n", @$_ }
2560                     sort { $a->[0] <=> $b->[0] } @failed;
2561         } else {
2562             $print = join "",
2563                 map { sprintf " %-45s: %s %s\n", @$_[1..3] }
2564                     sort {
2565                         $a->[0] <=> $b->[0]
2566                             ||
2567                                 $a->[4] <=> $b->[4]
2568                        } @failed;
2569         }
2570         $CPAN::Frontend->myprint("Failed during $scope:\n$print");
2571     } elsif (!$only_id || !$silent) {
2572         $CPAN::Frontend->myprint("Nothing failed in $scope\n");
2573     }
2574 }
2575
2576 # XXX intentionally undocumented because completely bogus, unportable,
2577 # useless, etc.
2578
2579 #-> sub CPAN::Shell::status ;
2580 sub status {
2581     my($self) = @_;
2582     require Devel::Size;
2583     my $ps = FileHandle->new;
2584     open $ps, "/proc/$$/status";
2585     my $vm = 0;
2586     while (<$ps>) {
2587         next unless /VmSize:\s+(\d+)/;
2588         $vm = $1;
2589         last;
2590     }
2591     $CPAN::Frontend->mywarn(sprintf(
2592                                     "%-27s %6d\n%-27s %6d\n",
2593                                     "vm",
2594                                     $vm,
2595                                     "CPAN::META",
2596                                     Devel::Size::total_size($CPAN::META)/1024,
2597                                    ));
2598     for my $k (sort keys %$CPAN::META) {
2599         next unless substr($k,0,4) eq "read";
2600         warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
2601         for my $k2 (sort keys %{$CPAN::META->{$k}}) {
2602             warn sprintf "  %-25s %6d (keys: %6d)\n",
2603                 $k2,
2604                     Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
2605                           scalar keys %{$CPAN::META->{$k}{$k2}};
2606         }
2607     }
2608 }
2609
2610 # compare with install_tested
2611 #-> sub CPAN::Shell::is_tested
2612 sub is_tested {
2613     my($self) = @_;
2614     CPAN::Index->reload;
2615     for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
2616         my $time;
2617         if ($CPAN::META->{is_tested}{$b}) {
2618             $time = scalar(localtime $CPAN::META->{is_tested}{$b});
2619         } else {
2620             $time = scalar localtime;
2621             $time =~ s/\S/?/g;
2622         }
2623         $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
2624     }
2625 }
2626
2627 #-> sub CPAN::Shell::autobundle ;
2628 sub autobundle {
2629     my($self) = shift;
2630     CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
2631     my(@bundle) = $self->_u_r_common("a",@_);
2632     my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
2633     File::Path::mkpath($todir);
2634     unless (-d $todir) {
2635         $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
2636         return;
2637     }
2638     my($y,$m,$d) =  (localtime)[5,4,3];
2639     $y+=1900;
2640     $m++;
2641     my($c) = 0;
2642     my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
2643     my($to) = File::Spec->catfile($todir,"$me.pm");
2644     while (-f $to) {
2645         $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
2646         $to = File::Spec->catfile($todir,"$me.pm");
2647     }
2648     my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
2649     $fh->print(
2650                "package Bundle::$me;\n\n",
2651                "\$VERSION = '0.01';\n\n",
2652                "1;\n\n",
2653                "__END__\n\n",
2654                "=head1 NAME\n\n",
2655                "Bundle::$me - Snapshot of installation on ",
2656                $Config::Config{'myhostname'},
2657                " on ",
2658                scalar(localtime),
2659                "\n\n=head1 SYNOPSIS\n\n",
2660                "perl -MCPAN -e 'install Bundle::$me'\n\n",
2661                "=head1 CONTENTS\n\n",
2662                join("\n", @bundle),
2663                "\n\n=head1 CONFIGURATION\n\n",
2664                Config->myconfig,
2665                "\n\n=head1 AUTHOR\n\n",
2666                "This Bundle has been generated automatically ",
2667                "by the autobundle routine in CPAN.pm.\n",
2668               );
2669     $fh->close;
2670     $CPAN::Frontend->myprint("\nWrote bundle file
2671     $to\n\n");
2672 }
2673
2674 #-> sub CPAN::Shell::expandany ;
2675 sub expandany {
2676     my($self,$s) = @_;
2677     CPAN->debug("s[$s]") if $CPAN::DEBUG;
2678     if ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
2679         $s = CPAN::Distribution->normalize($s);
2680         return $CPAN::META->instance('CPAN::Distribution',$s);
2681         # Distributions spring into existence, not expand
2682     } elsif ($s =~ m|^Bundle::|) {
2683         $self->local_bundles; # scanning so late for bundles seems
2684                               # both attractive and crumpy: always
2685                               # current state but easy to forget
2686                               # somewhere
2687         return $self->expand('Bundle',$s);
2688     } else {
2689         return $self->expand('Module',$s)
2690             if $CPAN::META->exists('CPAN::Module',$s);
2691     }
2692     return;
2693 }
2694
2695 #-> sub CPAN::Shell::expand ;
2696 sub expand {
2697     my $self = shift;
2698     my($type,@args) = @_;
2699     CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
2700     my $class = "CPAN::$type";
2701     my $methods = ['id'];
2702     for my $meth (qw(name)) {
2703         next unless $class->can($meth);
2704         push @$methods, $meth;
2705     }
2706     $self->expand_by_method($class,$methods,@args);
2707 }
2708
2709 #-> sub CPAN::Shell::expand_by_method ;
2710 sub expand_by_method {
2711     my $self = shift;
2712     my($class,$methods,@args) = @_;
2713     my($arg,@m);
2714     for $arg (@args) {
2715         my($regex,$command);
2716         if ($arg =~ m|^/(.*)/$|) {
2717             $regex = $1;
2718         } elsif ($arg =~ m/=/) {
2719             $command = 1;
2720         }
2721         my $obj;
2722         CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
2723                     $class,
2724                     defined $regex ? $regex : "UNDEFINED",
2725                     defined $command ? $command : "UNDEFINED",
2726                    ) if $CPAN::DEBUG;
2727         if (defined $regex) {
2728             if (CPAN::_sqlite_running) {
2729                 $CPAN::SQLite->search($class, $regex);
2730             }
2731             for $obj (
2732                       $CPAN::META->all_objects($class)
2733                      ) {
2734                 unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id){
2735                     # BUG, we got an empty object somewhere
2736                     require Data::Dumper;
2737                     CPAN->debug(sprintf(
2738                                         "Bug in CPAN: Empty id on obj[%s][%s]",
2739                                         $obj,
2740                                         Data::Dumper::Dumper($obj)
2741                                        )) if $CPAN::DEBUG;
2742                     next;
2743                 }
2744                 for my $method (@$methods) {
2745                     my $match = eval {$obj->$method() =~ /$regex/i};
2746                     if ($@) {
2747                         my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
2748                         $err ||= $@; # if we were too restrictive above
2749                         $CPAN::Frontend->mydie("$err\n");
2750                     } elsif ($match) {
2751                         push @m, $obj;
2752                         last;
2753                     }
2754                 }
2755             }
2756         } elsif ($command) {
2757             die "equal sign in command disabled (immature interface), ".
2758                 "you can set
2759  ! \$CPAN::Shell::ADVANCED_QUERY=1
2760 to enable it. But please note, this is HIGHLY EXPERIMENTAL code
2761 that may go away anytime.\n"
2762                     unless $ADVANCED_QUERY;
2763             my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
2764             my($matchcrit) = $criterion =~ m/^~(.+)/;
2765             for my $self (
2766                           sort
2767                           {$a->id cmp $b->id}
2768                           $CPAN::META->all_objects($class)
2769                          ) {
2770                 my $lhs = $self->$method() or next; # () for 5.00503
2771                 if ($matchcrit) {
2772                     push @m, $self if $lhs =~ m/$matchcrit/;
2773                 } else {
2774                     push @m, $self if $lhs eq $criterion;
2775                 }
2776             }
2777         } else {
2778             my($xarg) = $arg;
2779             if ( $class eq 'CPAN::Bundle' ) {
2780                 $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
2781             } elsif ($class eq "CPAN::Distribution") {
2782                 $xarg = CPAN::Distribution->normalize($arg);
2783             } else {
2784                 $xarg =~ s/:+/::/g;
2785             }
2786             if ($CPAN::META->exists($class,$xarg)) {
2787                 $obj = $CPAN::META->instance($class,$xarg);
2788             } elsif ($CPAN::META->exists($class,$arg)) {
2789                 $obj = $CPAN::META->instance($class,$arg);
2790             } else {
2791                 next;
2792             }
2793             push @m, $obj;
2794         }
2795     }
2796     @m = sort {$a->id cmp $b->id} @m;
2797     if ( $CPAN::DEBUG ) {
2798         my $wantarray = wantarray;
2799         my $join_m = join ",", map {$_->id} @m;
2800         $self->debug("wantarray[$wantarray]join_m[$join_m]");
2801     }
2802     return wantarray ? @m : $m[0];
2803 }
2804
2805 #-> sub CPAN::Shell::format_result ;
2806 sub format_result {
2807     my($self) = shift;
2808     my($type,@args) = @_;
2809     @args = '/./' unless @args;
2810     my(@result) = $self->expand($type,@args);
2811     my $result = @result == 1 ?
2812         $result[0]->as_string :
2813             @result == 0 ?
2814                 "No objects of type $type found for argument @args\n" :
2815                     join("",
2816                          (map {$_->as_glimpse} @result),
2817                          scalar @result, " items found\n",
2818                         );
2819     $result;
2820 }
2821
2822 #-> sub CPAN::Shell::report_fh ;
2823 {
2824     my $installation_report_fh;
2825     my $previously_noticed = 0;
2826
2827     sub report_fh {
2828         return $installation_report_fh if $installation_report_fh;
2829         if ($CPAN::META->has_inst("File::Temp")) {
2830             $installation_report_fh
2831                 = File::Temp->new(
2832                                   template => 'cpan_install_XXXX',
2833                                   suffix   => '.txt',
2834                                   unlink   => 0,
2835                                  );
2836         }
2837         unless ( $installation_report_fh ) {
2838             warn("Couldn't open installation report file; " .
2839                  "no report file will be generated."
2840                 ) unless $previously_noticed++;
2841         }
2842     }
2843 }
2844
2845
2846 # The only reason for this method is currently to have a reliable
2847 # debugging utility that reveals which output is going through which
2848 # channel. No, I don't like the colors ;-)
2849
2850 # to turn colordebugging on, write
2851 # cpan> o conf colorize_output 1
2852
2853 #-> sub CPAN::Shell::print_ornamented ;
2854 {
2855     my $print_ornamented_have_warned = 0;
2856     sub colorize_output {
2857         my $colorize_output = $CPAN::Config->{colorize_output};
2858         if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
2859             unless ($print_ornamented_have_warned++) {
2860                 # no myprint/mywarn within myprint/mywarn!
2861                 warn "Colorize_output is set to true but Term::ANSIColor is not
2862 installed. To activate colorized output, please install Term::ANSIColor.\n\n";
2863             }
2864             $colorize_output = 0;
2865         }
2866         return $colorize_output;
2867     }
2868 }
2869
2870
2871 #-> sub CPAN::Shell::print_ornamented ;
2872 sub print_ornamented {
2873     my($self,$what,$ornament) = @_;
2874     return unless defined $what;
2875
2876     local $| = 1; # Flush immediately
2877     if ( $CPAN::Be_Silent ) {
2878         print {report_fh()} $what;
2879         return;
2880     }
2881     my $swhat = "$what"; # stringify if it is an object
2882     if ($CPAN::Config->{term_is_latin}){
2883         # courtesy jhi:
2884         $swhat
2885             =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
2886     }
2887     if ($self->colorize_output) {
2888         if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
2889             # if you want to have this configurable, please file a bugreport
2890             $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
2891         }
2892         my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
2893         if ($@) {
2894             print "Term::ANSIColor rejects color[$ornament]: $@\n
2895 Please choose a different color (Hint: try 'o conf init /color/')\n";
2896         }
2897         print $color_on,
2898             $swhat,
2899                 Term::ANSIColor::color("reset");
2900     } else {
2901         print $swhat;
2902     }
2903 }
2904
2905 #-> sub CPAN::Shell::myprint ;
2906
2907 # where is myprint/mywarn/Frontend/etc. documented? We need guidelines
2908 # where to use what! I think, we send everything to STDOUT and use
2909 # print for normal/good news and warn for news that need more
2910 # attention. Yes, this is our working contract for now.
2911 sub myprint {
2912     my($self,$what) = @_;
2913
2914     $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white');
2915 }
2916
2917 #-> sub CPAN::Shell::myexit ;
2918 sub myexit {
2919     my($self,$what) = @_;
2920     $self->myprint($what);
2921     exit;
2922 }
2923
2924 #-> sub CPAN::Shell::mywarn ;
2925 sub mywarn {
2926     my($self,$what) = @_;
2927     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2928 }
2929
2930 # only to be used for shell commands
2931 #-> sub CPAN::Shell::mydie ;
2932 sub mydie {
2933     my($self,$what) = @_;
2934     $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
2935
2936     # If it is the shell, we want that the following die to be silent,
2937     # but if it is not the shell, we would need a 'die $what'. We need
2938     # to take care that only shell commands use mydie. Is this
2939     # possible?
2940
2941     die "\n";
2942 }
2943
2944 # sub CPAN::Shell::colorable_makemaker_prompt ;
2945 sub colorable_makemaker_prompt {
2946     my($foo,$bar) = @_;
2947     if (CPAN::Shell->colorize_output) {
2948         my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white';
2949         my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
2950         print $color_on;
2951     }
2952     my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
2953     if (CPAN::Shell->colorize_output) {
2954         print Term::ANSIColor::color('reset');
2955     }
2956     return $ans;
2957 }
2958
2959 # use this only for unrecoverable errors!
2960 #-> sub CPAN::Shell::unrecoverable_error ;
2961 sub unrecoverable_error {
2962     my($self,$what) = @_;
2963     my @lines = split /\n/, $what;
2964     my $longest = 0;
2965     for my $l (@lines) {
2966         $longest = length $l if length $l > $longest;
2967     }
2968     $longest = 62 if $longest > 62;
2969     for my $l (@lines) {
2970         if ($l =~ /^\s*$/){
2971             $l = "\n";
2972             next;
2973         }
2974         $l = "==> $l";
2975         if (length $l < 66) {
2976             $l = pack "A66 A*", $l, "<==";
2977         }
2978         $l .= "\n";
2979     }
2980     unshift @lines, "\n";
2981     $self->mydie(join "", @lines);
2982 }
2983
2984 #-> sub CPAN::Shell::mysleep ;
2985 sub mysleep {
2986     my($self, $sleep) = @_;
2987     use Time::HiRes qw(sleep);
2988     sleep $sleep;
2989 }
2990
2991 #-> sub CPAN::Shell::setup_output ;
2992 sub setup_output {
2993     return if -t STDOUT;
2994     my $odef = select STDERR;
2995     $| = 1;
2996     select STDOUT;
2997     $| = 1;
2998     select $odef;
2999 }
3000
3001 #-> sub CPAN::Shell::rematein ;
3002 # RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
3003 sub rematein {
3004     my $self = shift;
3005     my($meth,@some) = @_;
3006     my @pragma;
3007     while($meth =~ /^(ff?orce|notest)$/) {
3008         push @pragma, $meth;
3009         $meth = shift @some or
3010             $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
3011                                    "cannot continue");
3012     }
3013     setup_output();
3014     CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;
3015
3016     # Here is the place to set "test_count" on all involved parties to
3017     # 0. We then can pass this counter on to the involved
3018     # distributions and those can refuse to test if test_count > X. In
3019     # the first stab at it we could use a 1 for "X".
3020
3021     # But when do I reset the distributions to start with 0 again?
3022     # Jost suggested to have a random or cycling interaction ID that
3023     # we pass through. But the ID is something that is just left lying
3024     # around in addition to the counter, so I'd prefer to set the
3025     # counter to 0 now, and repeat at the end of the loop. But what
3026     # about dependencies? They appear later and are not reset, they
3027     # enter the queue but not its copy. How do they get a sensible
3028     # test_count?
3029
3030     my $needs_recursion_protection = "make|test|install";
3031
3032     # construct the queue
3033     my($s,@s,@qcopy);
3034   STHING: foreach $s (@some) {
3035         my $obj;
3036         if (ref $s) {
3037             CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
3038             $obj = $s;
3039         } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
3040         } elsif ($s =~ m|^/|) { # looks like a regexp
3041             if (substr($s,-1,1) eq ".") {
3042                 $obj = CPAN::Shell->expandany($s);
3043             } else {
3044                 $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
3045                                         "not supported.\nRejecting argument '$s'\n");
3046                 $CPAN::Frontend->mysleep(2);
3047                 next;
3048             }
3049         } elsif ($meth eq "ls") {
3050             $self->globls($s,\@pragma);
3051             next STHING;
3052         } else {
3053             CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
3054             $obj = CPAN::Shell->expandany($s);
3055         }
3056         if (0) {
3057         } elsif (ref $obj) {
3058             if ($meth =~ /^($needs_recursion_protection)$/) {
3059                 # it would be silly to check for recursion for look or dump
3060                 # (we are in CPAN::Shell::rematein)
3061                 CPAN->debug("Going to test against recursion") if $CPAN::DEBUG;
3062                 eval {  $obj->color_cmd_tmps(0,1); };
3063                 if ($@){
3064                     if (ref $@
3065                         and $@->isa("CPAN::Exception::RecursiveDependency")) {
3066                         $CPAN::Frontend->mywarn($@);
3067                     } else {
3068                         if (0) {
3069                             require Carp;
3070                             Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
3071                         }
3072                         die;
3073                     }
3074                 }
3075             }
3076             CPAN::Queue->new(qmod => $obj->id, reqtype => "c");
3077             push @qcopy, $obj;
3078         } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
3079             $obj = $CPAN::META->instance('CPAN::Author',uc($s));
3080             if ($meth =~ /^(dump|ls)$/) {
3081                 $obj->$meth();
3082             } else {
3083                 $CPAN::Frontend->mywarn(
3084                                         join "",
3085                                         "Don't be silly, you can't $meth ",
3086                                         $obj->fullname,
3087                                         " ;-)\n"
3088                                        );
3089                 $CPAN::Frontend->mysleep(2);
3090             }
3091         } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
3092             CPAN::InfoObj->dump($s);
3093         } else {
3094             $CPAN::Frontend
3095                 ->mywarn(qq{Warning: Cannot $meth $s, }.
3096                           qq{don't know what it is.
3097 Try the command
3098
3099     i /$s/
3100
3101 to find objects with matching identifiers.
3102 });
3103             $CPAN::Frontend->mysleep(2);
3104         }
3105     }
3106
3107     # queuerunner (please be warned: when I started to change the
3108     # queue to hold objects instead of names, I made one or two
3109     # mistakes and never found which. I reverted back instead)
3110     while (my $q = CPAN::Queue->first) {
3111         my $obj;
3112         my $s = $q->as_string;
3113         my $reqtype = $q->reqtype || "";
3114         $obj = CPAN::Shell->expandany($s);
3115         unless ($obj) {
3116             # don't know how this can happen, maybe we should panic,
3117             # but maybe we get a solution from the first user who hits
3118             # this unfortunate exception?
3119             $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
3120                                     "to an object. Skipping.\n");
3121             $CPAN::Frontend->mysleep(5);
3122             CPAN::Queue->delete_first($s);
3123             next;
3124         }
3125         $obj->{reqtype} ||= "";
3126         {
3127             # force debugging because CPAN::SQLite somehow delivers us
3128             # an empty object;
3129
3130             # local $CPAN::DEBUG = 1024; # Shell; probably fixed now
3131
3132             CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
3133                         "q-reqtype[$reqtype]") if $CPAN::DEBUG;
3134         }
3135         if ($obj->{reqtype}) {
3136             if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
3137                 $obj->{reqtype} = $reqtype;
3138                 if (
3139                     exists $obj->{install}
3140                     &&
3141                     (
3142                      UNIVERSAL::can($obj->{install},"failed") ?
3143                      $obj->{install}->failed :
3144                      $obj->{install} =~ /^NO/
3145                     )
3146                    ) {
3147                     delete $obj->{install};
3148                     $CPAN::Frontend->mywarn
3149                         ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
3150                 }
3151             }
3152         } else {
3153             $obj->{reqtype} = $reqtype;
3154         }
3155
3156         for my $pragma (@pragma) {
3157             if ($pragma
3158                 &&
3159                 $obj->can($pragma)){
3160                 $obj->$pragma($meth);
3161             }
3162         }
3163         if (UNIVERSAL::can($obj, 'called_for')) {
3164             $obj->called_for($s);
3165         }
3166         CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
3167                     qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;
3168
3169         push @qcopy, $obj;
3170         if (! UNIVERSAL::can($obj,$meth)) {
3171             # Must never happen
3172             my $serialized = "";
3173             if (0) {
3174             } elsif ($CPAN::META->has_inst("YAML::Syck")) {
3175                 $serialized = YAML::Syck::Dump($obj);
3176             } elsif ($CPAN::META->has_inst("YAML")) {
3177                 $serialized = YAML::Dump($obj);
3178             } elsif ($CPAN::META->has_inst("Data::Dumper")) {
3179                 $serialized = Data::Dumper::Dumper($obj);
3180             } else {
3181                 require overload;
3182                 $serialized = overload::StrVal($obj);
3183             }
3184             CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
3185             $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
3186         } elsif ($obj->$meth()){
3187             CPAN::Queue->delete($s);
3188             CPAN->debug("From queue deleted. meth[$meth]s[$s]") if $CPAN::DEBUG;
3189         } else {
3190             CPAN->debug("Failed. pragma[@pragma]meth[$meth]") if $CPAN::DEBUG;
3191         }
3192
3193         $obj->undelay;
3194         for my $pragma (@pragma) {
3195             my $unpragma = "un$pragma";
3196             if ($obj->can($unpragma)) {
3197                 $obj->$unpragma();
3198             }
3199         }
3200         CPAN::Queue->delete_first($s);
3201     }
3202     if ($meth =~ /^($needs_recursion_protection)$/) {
3203         for my $obj (@qcopy) {
3204             $obj->color_cmd_tmps(0,0);
3205         }
3206     }
3207 }
3208
3209 #-> sub CPAN::Shell::recent ;
3210 sub recent {
3211   my($self) = @_;
3212
3213   CPAN::Distribution::_display_url( $self, $CPAN::Defaultrecent );
3214   return;
3215 }
3216
3217 {
3218     # set up the dispatching methods
3219     no strict "refs";
3220     for my $command (qw(
3221                         clean
3222                         cvs_import
3223                         dump
3224                         force
3225                         fforce
3226                         get
3227                         install
3228                         look
3229                         ls
3230                         make
3231                         notest
3232                         perldoc
3233                         readme
3234                         test
3235                        )) {
3236         *$command = sub { shift->rematein($command, @_); };
3237     }
3238 }
3239
3240 package CPAN::LWP::UserAgent;
3241 use strict;
3242
3243 sub config {
3244     return if $SETUPDONE;
3245     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3246         require LWP::UserAgent;
3247         @ISA = qw(Exporter LWP::UserAgent);
3248         $SETUPDONE++;
3249     } else {
3250         $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
3251     }
3252 }
3253
3254 sub get_basic_credentials {
3255     my($self, $realm, $uri, $proxy) = @_;
3256     if ($USER && $PASSWD) {
3257         return ($USER, $PASSWD);
3258     }
3259     if ( $proxy ) {
3260         ($USER,$PASSWD) = $self->get_proxy_credentials();
3261     } else {
3262         ($USER,$PASSWD) = $self->get_non_proxy_credentials();
3263     }
3264     return($USER,$PASSWD);
3265 }
3266
3267 sub get_proxy_credentials {
3268     my $self = shift;
3269     my ($user, $password);
3270     if ( defined $CPAN::Config->{proxy_user} &&
3271          defined $CPAN::Config->{proxy_pass}) {
3272         $user = $CPAN::Config->{proxy_user};
3273         $password = $CPAN::Config->{proxy_pass};
3274         return ($user, $password);
3275     }
3276     my $username_prompt = "\nProxy authentication needed!
3277  (Note: to permanently configure username and password run
3278    o conf proxy_user your_username
3279    o conf proxy_pass your_password
3280      )\nUsername:";
3281     ($user, $password) =
3282         _get_username_and_password_from_user($username_prompt);
3283     return ($user,$password);
3284 }
3285
3286 sub get_non_proxy_credentials {
3287     my $self = shift;
3288     my ($user,$password);
3289     if ( defined $CPAN::Config->{username} &&
3290          defined $CPAN::Config->{password}) {
3291         $user = $CPAN::Config->{username};
3292         $password = $CPAN::Config->{password};
3293         return ($user, $password);
3294     }
3295     my $username_prompt = "\nAuthentication needed!
3296      (Note: to permanently configure username and password run
3297        o conf username your_username
3298        o conf password your_password
3299      )\nUsername:";
3300
3301     ($user, $password) =
3302         _get_username_and_password_from_user($username_prompt);
3303     return ($user,$password);
3304 }
3305
3306 sub _get_username_and_password_from_user {
3307     my $username_message = shift;
3308     my ($username,$password);
3309
3310     ExtUtils::MakeMaker->import(qw(prompt));
3311     $username = prompt($username_message);
3312         if ($CPAN::META->has_inst("Term::ReadKey")) {
3313             Term::ReadKey::ReadMode("noecho");
3314         }
3315     else {
3316         $CPAN::Frontend->mywarn(
3317             "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
3318         );
3319     }
3320     $password = prompt("Password:");
3321
3322         if ($CPAN::META->has_inst("Term::ReadKey")) {
3323             Term::ReadKey::ReadMode("restore");
3324         }
3325         $CPAN::Frontend->myprint("\n\n");
3326     return ($username,$password);
3327 }
3328
3329 # mirror(): Its purpose is to deal with proxy authentication. When we
3330 # call SUPER::mirror, we relly call the mirror method in
3331 # LWP::UserAgent. LWP::UserAgent will then call
3332 # $self->get_basic_credentials or some equivalent and this will be
3333 # $self->dispatched to our own get_basic_credentials method.
3334
3335 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3336
3337 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3338 # although we have gone through our get_basic_credentials, the proxy
3339 # server refuses to connect. This could be a case where the username or
3340 # password has changed in the meantime, so I'm trying once again without
3341 # $USER and $PASSWD to give the get_basic_credentials routine another
3342 # chance to set $USER and $PASSWD.
3343
3344 # mirror(): Its purpose is to deal with proxy authentication. When we
3345 # call SUPER::mirror, we relly call the mirror method in
3346 # LWP::UserAgent. LWP::UserAgent will then call
3347 # $self->get_basic_credentials or some equivalent and this will be
3348 # $self->dispatched to our own get_basic_credentials method.
3349
3350 # Our own get_basic_credentials sets $USER and $PASSWD, two globals.
3351
3352 # 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
3353 # although we have gone through our get_basic_credentials, the proxy
3354 # server refuses to connect. This could be a case where the username or
3355 # password has changed in the meantime, so I'm trying once again without
3356 # $USER and $PASSWD to give the get_basic_credentials routine another
3357 # chance to set $USER and $PASSWD.
3358
3359 sub mirror {
3360     my($self,$url,$aslocal) = @_;
3361     my $result = $self->SUPER::mirror($url,$aslocal);
3362     if ($result->code == 407) {
3363         undef $USER;
3364         undef $PASSWD;
3365         $result = $self->SUPER::mirror($url,$aslocal);
3366     }
3367     $result;
3368 }
3369
3370 package CPAN::FTP;
3371 use strict;
3372
3373 #-> sub CPAN::FTP::ftp_statistics
3374 # if they want to rewrite, they need to pass in a filehandle
3375 sub _ftp_statistics {
3376     my($self,$fh) = @_;
3377     my $locktype = $fh ? LOCK_EX : LOCK_SH;
3378     $fh ||= FileHandle->new;
3379     my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3380     open $fh, "+>>$file" or $CPAN::Frontend->mydie("Could not open '$file': $!");
3381     my $sleep = 1;
3382     my $waitstart;
3383     while (!flock $fh, $locktype|LOCK_NB) {
3384         $waitstart ||= localtime();
3385         if ($sleep>3) {
3386             $CPAN::Frontend->mywarn("Waiting for a read lock on '$file' (since $waitstart)\n");
3387         }
3388         $CPAN::Frontend->mysleep($sleep);
3389         if ($sleep <= 3) {
3390             $sleep+=0.33;
3391         } elsif ($sleep <=6) {
3392             $sleep+=0.11;
3393         }
3394     }
3395     my $stats = eval { CPAN->_yaml_loadfile($file); };
3396     if ($@) {
3397         if (ref $@) {
3398             if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
3399                 $CPAN::Frontend->myprint("Warning (usually harmless): $@");
3400                 return;
3401             } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
3402                 $CPAN::Frontend->mydie($@);
3403             }
3404         } else {
3405             $CPAN::Frontend->mydie($@);
3406         }
3407     }
3408     return $stats->[0];
3409 }
3410
3411 #-> sub CPAN::FTP::_mytime
3412 sub _mytime () {
3413     if (CPAN->has_inst("Time::HiRes")) {
3414         return Time::HiRes::time();
3415     } else {
3416         return time;
3417     }
3418 }
3419
3420 #-> sub CPAN::FTP::_new_stats
3421 sub _new_stats {
3422     my($self,$file) = @_;
3423     my $ret = {
3424                file => $file,
3425                attempts => [],
3426                start => _mytime,
3427               };
3428     $ret;
3429 }
3430
3431 #-> sub CPAN::FTP::_add_to_statistics
3432 sub _add_to_statistics {
3433     my($self,$stats) = @_;
3434     my $yaml_module = CPAN::_yaml_module;
3435     $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
3436     if ($CPAN::META->has_inst($yaml_module)) {
3437         $stats->{thesiteurl} = $ThesiteURL;
3438         if (CPAN->has_inst("Time::HiRes")) {
3439             $stats->{end} = Time::HiRes::time();
3440         } else {
3441             $stats->{end} = time;
3442         }
3443         my $fh = FileHandle->new;
3444         my $time = time;
3445         my $sdebug = 0;
3446         my @debug;
3447         @debug = $time if $sdebug;
3448         my $fullstats = $self->_ftp_statistics($fh);
3449         close $fh;
3450         $fullstats->{history} ||= [];
3451         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3452         push @debug, time if $sdebug;
3453         push @{$fullstats->{history}}, $stats;
3454         # arbitrary hardcoded constants until somebody demands to have
3455         # them settable; YAML.pm 0.62 is unacceptably slow with 999;
3456         # YAML::Syck 0.82 has no noticable performance problem with 999;
3457         while (
3458                @{$fullstats->{history}} > 99
3459                || $time - $fullstats->{history}[0]{start} > 14*86400
3460               ) {
3461             shift @{$fullstats->{history}}
3462         }
3463         push @debug, scalar @{$fullstats->{history}} if $sdebug;
3464         push @debug, time if $sdebug;
3465         push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
3466         # need no eval because if this fails, it is serious
3467         my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
3468         CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
3469         if ( $sdebug ) {
3470             local $CPAN::DEBUG = 512; # FTP
3471             push @debug, time;
3472             CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
3473                                 "after[%d]at[%d]oldest[%s]dumped backat[%d]",
3474                                 @debug,
3475                                ));
3476         }
3477         # Win32 cannot rename a file to an existing filename
3478         unlink($sfile) if ($^O eq 'MSWin32');
3479         rename "$sfile.$$", $sfile
3480             or $CPAN::Frontend->mydie("Could not rename '$sfile.$$' to '$sfile': $!\n");
3481     }
3482 }
3483
3484 # if file is CHECKSUMS, suggest the place where we got the file to be
3485 # checked from, maybe only for young files?
3486 #-> sub CPAN::FTP::_recommend_url_for
3487 sub _recommend_url_for {
3488     my($self, $file) = @_;
3489     my $urllist = $self->_get_urllist;
3490     if ($file =~ s|/CHECKSUMS(.gz)?$||) {
3491         my $fullstats = $self->_ftp_statistics();
3492         my $history = $fullstats->{history} || [];
3493         while (my $last = pop @$history) {
3494             last if $last->{end} - time > 3600; # only young results are interesting
3495             next unless $last->{file}; # dirname of nothing dies!
3496             next unless $file eq File::Basename::dirname($last->{file});
3497             return $last->{thesiteurl};
3498         }
3499     }
3500     if ($CPAN::Config->{randomize_urllist}
3501         &&
3502         rand(1) < $CPAN::Config->{randomize_urllist}
3503        ) {
3504         $urllist->[int rand scalar @$urllist];
3505     } else {
3506         return ();
3507     }
3508 }
3509
3510 #-> sub CPAN::FTP::_get_urllist
3511 sub _get_urllist {
3512     my($self) = @_;
3513     $CPAN::Config->{urllist} ||= [];
3514     unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
3515         $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
3516         $CPAN::Config->{urllist} = [];
3517     }
3518     my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
3519     for my $u (@urllist) {
3520         CPAN->debug("u[$u]") if $CPAN::DEBUG;
3521         if (UNIVERSAL::can($u,"text")) {
3522             $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
3523         } else {
3524             $u .= "/" unless substr($u,-1) eq "/";
3525             $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
3526         }
3527     }
3528     \@urllist;
3529 }
3530
3531 #-> sub CPAN::FTP::ftp_get ;
3532 sub ftp_get {
3533     my($class,$host,$dir,$file,$target) = @_;
3534     $class->debug(
3535                   qq[Going to fetch file [$file] from dir [$dir]
3536         on host [$host] as local [$target]\n]
3537                  ) if $CPAN::DEBUG;
3538     my $ftp = Net::FTP->new($host);
3539     unless ($ftp) {
3540         $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
3541         return;
3542     }
3543     return 0 unless defined $ftp;
3544     $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
3545     $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
3546     unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ){
3547         my $msg = $ftp->message;
3548         $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg");
3549         return;
3550     }
3551     unless ( $ftp->cwd($dir) ){
3552         my $msg = $ftp->message;
3553         $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg");
3554         return;
3555     }
3556     $ftp->binary;
3557     $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
3558     unless ( $ftp->get($file,$target) ){
3559         my $msg = $ftp->message;
3560         $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg");
3561         return;
3562     }
3563     $ftp->quit; # it's ok if this fails
3564     return 1;
3565 }
3566
3567 # If more accuracy is wanted/needed, Chris Leach sent me this patch...
3568
3569  # > *** /install/perl/live/lib/CPAN.pm-        Wed Sep 24 13:08:48 1997
3570  # > --- /tmp/cp        Wed Sep 24 13:26:40 1997
3571  # > ***************
3572  # > *** 1562,1567 ****
3573  # > --- 1562,1580 ----
3574  # >       return 1 if substr($url,0,4) eq "file";
3575  # >       return 1 unless $url =~ m|://([^/]+)|;
3576  # >       my $host = $1;
3577  # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
3578  # > +     if ($proxy) {
3579  # > +         $proxy =~ m|://([^/:]+)|;
3580  # > +         $proxy = $1;
3581  # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
3582  # > +         if ($noproxy) {
3583  # > +             if ($host !~ /$noproxy$/) {
3584  # > +                 $host = $proxy;
3585  # > +             }
3586  # > +         } else {
3587  # > +             $host = $proxy;
3588  # > +         }
3589  # > +     }
3590  # >       require Net::Ping;
3591  # >       return 1 unless $Net::Ping::VERSION >= 2;
3592  # >       my $p;
3593
3594
3595 #-> sub CPAN::FTP::localize ;
3596 sub localize {
3597     my($self,$file,$aslocal,$force) = @_;
3598     $force ||= 0;
3599     Carp::croak "Usage: ->localize(cpan_file,as_local_file[,$force])"
3600         unless defined $aslocal;
3601     $self->debug("file[$file] aslocal[$aslocal] force[$force]")
3602         if $CPAN::DEBUG;
3603
3604     if ($^O eq 'MacOS') {
3605         # Comment by AK on 2000-09-03: Uniq short filenames would be
3606         # available in CHECKSUMS file
3607         my($name, $path) = File::Basename::fileparse($aslocal, '');
3608         if (length($name) > 31) {
3609             $name =~ s/(
3610                         \.(
3611                            readme(\.(gz|Z))? |
3612                            (tar\.)?(gz|Z) |
3613                            tgz |
3614                            zip |
3615                            pm\.(gz|Z)
3616                           )
3617                        )$//x;
3618             my $suf = $1;
3619             my $size = 31 - length($suf);
3620             while (length($name) > $size) {
3621                 chop $name;
3622             }
3623             $name .= $suf;
3624             $aslocal = File::Spec->catfile($path, $name);
3625         }
3626     }
3627
3628     if (-f $aslocal && -r _ && !($force & 1)){
3629         my $size;
3630         if ($size = -s $aslocal) {
3631             $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
3632             return $aslocal;
3633         } else {
3634             # empty file from a previous unsuccessful attempt to download it
3635             unlink $aslocal or
3636                 $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
3637                                        "could not remove.");
3638         }
3639     }
3640     my($maybe_restore) = 0;
3641     if (-f $aslocal){
3642         rename $aslocal, "$aslocal.bak$$";
3643         $maybe_restore++;
3644     }
3645
3646     my($aslocal_dir) = File::Basename::dirname($aslocal);
3647     File::Path::mkpath($aslocal_dir);
3648     $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
3649         qq{directory "$aslocal_dir".
3650     I\'ll continue, but if you encounter problems, they may be due
3651     to insufficient permissions.\n}) unless -w $aslocal_dir;
3652
3653     # Inheritance is not easier to manage than a few if/else branches
3654     if ($CPAN::META->has_usable('LWP::UserAgent')) {
3655         unless ($Ua) {
3656             CPAN::LWP::UserAgent->config;
3657             eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
3658             if ($@) {
3659                 $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
3660                     if $CPAN::DEBUG;
3661             } else {
3662                 my($var);
3663                 $Ua->proxy('ftp',  $var)
3664                     if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
3665                 $Ua->proxy('http', $var)
3666                     if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
3667
3668
3669 # >>>>> On Wed, 13 Dec 2000 09:21:34 -0500, "Robison, Jonathon (J.M.)" <jrobiso2@visteon.com> said:
3670 #
3671 #  > I note that although CPAN.pm can use proxies, it doesn't seem equipped to
3672 #  > use ones that require basic autorization.
3673 #
3674 #  > Example of when I use it manually in my own stuff:
3675 #
3676 #  > $ua->proxy(['http','ftp'], http://my.proxy.server:83');
3677 #  > $req->proxy_authorization_basic("username","password");
3678 #  > $res = $ua->request($req);
3679 #
3680
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                 && !$do->{make_test}->failed
4641                 && (
4642                     !$do->{install}
4643                     ||
4644                     $do->{install}->failed
4645                    )
4646                ) {
4647                 $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
4648             }
4649             $restored++;
4650         }
4651         $i++;
4652         while (($painted/76) < ($i/@candidates)) {
4653             $CPAN::Frontend->myprint(".");
4654             $painted++;
4655         }
4656     }
4657     $CPAN::Frontend->myprint(sprintf(
4658                                      "DONE\nFound %s old build%s, restored the state of %s\n",
4659                                      @candidates ? sprintf("%d",scalar @candidates) : "no",
4660                                      @candidates==1 ? "" : "s",
4661                                      $restored || "none",
4662                                     ));
4663 }
4664
4665
4666 #-> sub CPAN::Index::reload_x ;
4667 sub reload_x {
4668     my($cl,$wanted,$localname,$force) = @_;
4669     $force |= 2; # means we're dealing with an index here
4670     CPAN::HandleConfig->load; # we should guarantee loading wherever
4671                               # we rely on Config XXX
4672     $localname ||= $wanted;
4673     my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
4674                                          $localname);
4675     if (
4676         -f $abs_wanted &&
4677         -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
4678         !($force & 1)
4679        ) {
4680         my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
4681         $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
4682                    qq{day$s. I\'ll use that.});
4683         return $abs_wanted;
4684     } else {
4685         $force |= 1; # means we're quite serious about it.
4686     }
4687     return CPAN::FTP->localize($wanted,$abs_wanted,$force);
4688 }
4689
4690 #-> sub CPAN::Index::rd_authindex ;
4691 sub rd_authindex {
4692     my($cl, $index_target) = @_;
4693     return unless defined $index_target;
4694     return if CPAN::_sqlite_running;
4695     my @lines;
4696     $CPAN::Frontend->myprint("Going to read $index_target\n");
4697     local(*FH);
4698     tie *FH, 'CPAN::Tarzip', $index_target;
4699     local($/) = "\n";
4700     local($_);
4701     push @lines, split /\012/ while <FH>;
4702     my $i = 0;
4703     my $painted = 0;
4704     foreach (@lines) {
4705         my($userid,$fullname,$email) =
4706             m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
4707         $fullname ||= $email;
4708         if ($userid && $fullname && $email){
4709             my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
4710             $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
4711         } else {
4712             CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
4713         }
4714         $i++;
4715         while (($painted/76) < ($i/@lines)) {
4716             $CPAN::Frontend->myprint(".");
4717             $painted++;
4718         }
4719         return if $CPAN::Signal;
4720     }
4721     $CPAN::Frontend->myprint("DONE\n");
4722 }
4723
4724 sub userid {
4725   my($self,$dist) = @_;
4726   $dist = $self->{'id'} unless defined $dist;
4727   my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
4728   $ret;
4729 }
4730
4731 #-> sub CPAN::Index::rd_modpacks ;
4732 sub rd_modpacks {
4733     my($self, $index_target) = @_;
4734     return unless defined $index_target;
4735     return if CPAN::_sqlite_running;
4736     $CPAN::Frontend->myprint("Going to read $index_target\n");
4737     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4738     local $_;
4739     CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
4740     my $slurp = "";
4741     my $chunk;
4742     while (my $bytes = $fh->READ(\$chunk,8192)) {
4743         $slurp.=$chunk;
4744     }
4745     my @lines = split /\012/, $slurp;
4746     CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
4747     undef $fh;
4748     # read header
4749     my($line_count,$last_updated);
4750     while (@lines) {
4751         my $shift = shift(@lines);
4752         last if $shift =~ /^\s*$/;
4753         $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
4754         $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
4755     }
4756     CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
4757     if (not defined $line_count) {
4758
4759         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
4760 Please check the validity of the index file by comparing it to more
4761 than one CPAN mirror. I'll continue but problems seem likely to
4762 happen.\a
4763 });
4764
4765         $CPAN::Frontend->mysleep(5);
4766     } elsif ($line_count != scalar @lines) {
4767
4768         $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
4769 contains a Line-Count header of %d but I see %d lines there. Please
4770 check the validity of the index file by comparing it to more than one
4771 CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
4772 $index_target, $line_count, scalar(@lines));
4773
4774     }
4775     if (not defined $last_updated) {
4776
4777         $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
4778 Please check the validity of the index file by comparing it to more
4779 than one CPAN mirror. I'll continue but problems seem likely to
4780 happen.\a
4781 });
4782
4783         $CPAN::Frontend->mysleep(5);
4784     } else {
4785
4786         $CPAN::Frontend
4787             ->myprint(sprintf qq{  Database was generated on %s\n},
4788                       $last_updated);
4789         $DATE_OF_02 = $last_updated;
4790
4791         my $age = time;
4792         if ($CPAN::META->has_inst('HTTP::Date')) {
4793             require HTTP::Date;
4794             $age -= HTTP::Date::str2time($last_updated);
4795         } else {
4796             $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
4797             require Time::Local;
4798             my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
4799             $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
4800             $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
4801         }
4802         $age /= 3600*24;
4803         if ($age > 30) {
4804
4805             $CPAN::Frontend
4806                 ->mywarn(sprintf
4807                          qq{Warning: This index file is %d days old.
4808   Please check the host you chose as your CPAN mirror for staleness.
4809   I'll continue but problems seem likely to happen.\a\n},
4810                          $age);
4811
4812         } elsif ($age < -1) {
4813
4814             $CPAN::Frontend
4815                 ->mywarn(sprintf
4816                          qq{Warning: Your system date is %d days behind this index file!
4817   System time:          %s
4818   Timestamp index file: %s
4819   Please fix your system time, problems with the make command expected.\n},
4820                          -$age,
4821                          scalar gmtime,
4822                          $DATE_OF_02,
4823                         );
4824
4825         }
4826     }
4827
4828
4829     # A necessity since we have metadata_cache: delete what isn't
4830     # there anymore
4831     my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
4832     CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
4833     my(%exists);
4834     my $i = 0;
4835     my $painted = 0;
4836     foreach (@lines) {
4837         # before 1.56 we split into 3 and discarded the rest. From
4838         # 1.57 we assign remaining text to $comment thus allowing to
4839         # influence isa_perl
4840         my($mod,$version,$dist,$comment) = split " ", $_, 4;
4841         my($bundle,$id,$userid);
4842
4843         if ($mod eq 'CPAN' &&
4844             ! (
4845                CPAN::Queue->exists('Bundle::CPAN') ||
4846                CPAN::Queue->exists('CPAN')
4847               )
4848            ) {
4849             local($^W)= 0;
4850             if ($version > $CPAN::VERSION){
4851                 $CPAN::Frontend->mywarn(qq{
4852   New CPAN.pm version (v$version) available.
4853   [Currently running version is v$CPAN::VERSION]
4854   You might want to try
4855     install CPAN
4856     reload cpan
4857   to both upgrade CPAN.pm and run the new version without leaving
4858   the current session.
4859
4860 }); #});
4861                 $CPAN::Frontend->mysleep(2);
4862                 $CPAN::Frontend->myprint(qq{\n});
4863             }
4864             last if $CPAN::Signal;
4865         } elsif ($mod =~ /^Bundle::(.*)/) {
4866             $bundle = $1;
4867         }
4868
4869         if ($bundle){
4870             $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
4871             # Let's make it a module too, because bundles have so much
4872             # in common with modules.
4873
4874             # Changed in 1.57_63: seems like memory bloat now without
4875             # any value, so commented out
4876
4877             # $CPAN::META->instance('CPAN::Module',$mod);
4878
4879         } else {
4880
4881             # instantiate a module object
4882             $id = $CPAN::META->instance('CPAN::Module',$mod);
4883
4884         }
4885
4886         # Although CPAN prohibits same name with different version the
4887         # indexer may have changed the version for the same distro
4888         # since the last time ("Force Reindexing" feature)
4889         if ($id->cpan_file ne $dist
4890             ||
4891             $id->cpan_version ne $version
4892            ){
4893             $userid = $id->userid || $self->userid($dist);
4894             $id->set(
4895                      'CPAN_USERID' => $userid,
4896                      'CPAN_VERSION' => $version,
4897                      'CPAN_FILE' => $dist,
4898                     );
4899         }
4900
4901         # instantiate a distribution object
4902         if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
4903           # we do not need CONTAINSMODS unless we do something with
4904           # this dist, so we better produce it on demand.
4905
4906           ## my $obj = $CPAN::META->instance(
4907           ##                              'CPAN::Distribution' => $dist
4908           ##                             );
4909           ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
4910         } else {
4911           $CPAN::META->instance(
4912                                 'CPAN::Distribution' => $dist
4913                                )->set(
4914                                       'CPAN_USERID' => $userid,
4915                                       'CPAN_COMMENT' => $comment,
4916                                      );
4917         }
4918         if ($secondtime) {
4919             for my $name ($mod,$dist) {
4920                 # $self->debug("exists name[$name]") if $CPAN::DEBUG;
4921                 $exists{$name} = undef;
4922             }
4923         }
4924         $i++;
4925         while (($painted/76) < ($i/@lines)) {
4926             $CPAN::Frontend->myprint(".");
4927             $painted++;
4928         }
4929         return if $CPAN::Signal;
4930     }
4931     $CPAN::Frontend->myprint("DONE\n");
4932     if ($secondtime) {
4933         for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
4934             for my $o ($CPAN::META->all_objects($class)) {
4935                 next if exists $exists{$o->{ID}};
4936                 $CPAN::META->delete($class,$o->{ID});
4937                 # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
4938                 #     if $CPAN::DEBUG;
4939             }
4940         }
4941     }
4942 }
4943
4944 #-> sub CPAN::Index::rd_modlist ;
4945 sub rd_modlist {
4946     my($cl,$index_target) = @_;
4947     return unless defined $index_target;
4948     return if CPAN::_sqlite_running;
4949     $CPAN::Frontend->myprint("Going to read $index_target\n");
4950     my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
4951     local $_;
4952     my $slurp = "";
4953     my $chunk;
4954     while (my $bytes = $fh->READ(\$chunk,8192)) {
4955         $slurp.=$chunk;
4956     }
4957     my @eval2 = split /\012/, $slurp;
4958
4959     while (@eval2) {
4960         my $shift = shift(@eval2);
4961         if ($shift =~ /^Date:\s+(.*)/){
4962             if ($DATE_OF_03 eq $1){
4963                 $CPAN::Frontend->myprint("Unchanged.\n");
4964                 return;
4965             }
4966             ($DATE_OF_03) = $1;
4967         }
4968         last if $shift =~ /^\s*$/;
4969     }
4970     push @eval2, q{CPAN::Modulelist->data;};
4971     local($^W) = 0;
4972     my($comp) = Safe->new("CPAN::Safe1");
4973     my($eval2) = join("\n", @eval2);
4974     CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
4975     my $ret = $comp->reval($eval2);
4976     Carp::confess($@) if $@;
4977     return if $CPAN::Signal;
4978     my $i = 0;
4979     my $until = keys(%$ret);
4980     my $painted = 0;
4981     CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
4982     for (keys %$ret) {
4983         my $obj = $CPAN::META->instance("CPAN::Module",$_);
4984         delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
4985         $obj->set(%{$ret->{$_}});
4986         $i++;
4987         while (($painted/76) < ($i/$until)) {
4988             $CPAN::Frontend->myprint(".");
4989             $painted++;
4990         }
4991         return if $CPAN::Signal;
4992     }
4993     $CPAN::Frontend->myprint("DONE\n");
4994 }
4995
4996 #-> sub CPAN::Index::write_metadata_cache ;
4997 sub write_metadata_cache {
4998     my($self) = @_;
4999     return unless $CPAN::Config->{'cache_metadata'};
5000     return if CPAN::_sqlite_running;
5001     return unless $CPAN::META->has_usable("Storable");
5002     my $cache;
5003     foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
5004                       CPAN::Distribution)) {
5005         $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
5006     }
5007     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5008     $cache->{last_time} = $LAST_TIME;
5009     $cache->{DATE_OF_02} = $DATE_OF_02;
5010     $cache->{PROTOCOL} = PROTOCOL;
5011     $CPAN::Frontend->myprint("Going to write $metadata_file\n");
5012     eval { Storable::nstore($cache, $metadata_file) };
5013     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5014 }
5015
5016 #-> sub CPAN::Index::read_metadata_cache ;
5017 sub read_metadata_cache {
5018     my($self) = @_;
5019     return unless $CPAN::Config->{'cache_metadata'};
5020     return if CPAN::_sqlite_running;
5021     return unless $CPAN::META->has_usable("Storable");
5022     my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
5023     return unless -r $metadata_file and -f $metadata_file;
5024     $CPAN::Frontend->myprint("Going to read $metadata_file\n");
5025     my $cache;
5026     eval { $cache = Storable::retrieve($metadata_file) };
5027     $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
5028     if (!$cache || !UNIVERSAL::isa($cache, 'HASH')){
5029         $LAST_TIME = 0;
5030         return;
5031     }
5032     if (exists $cache->{PROTOCOL}) {
5033         if (PROTOCOL > $cache->{PROTOCOL}) {
5034             $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
5035                                             "with protocol v%s, requiring v%s\n",
5036                                             $cache->{PROTOCOL},
5037                                             PROTOCOL)
5038                                    );
5039             return;
5040         }
5041     } else {
5042         $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
5043                                 "with protocol v1.0\n");
5044         return;
5045     }
5046     my $clcnt = 0;
5047     my $idcnt = 0;
5048     while(my($class,$v) = each %$cache) {
5049         next unless $class =~ /^CPAN::/;
5050         $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
5051         while (my($id,$ro) = each %$v) {
5052             $CPAN::META->{readwrite}{$class}{$id} ||=
5053                 $class->new(ID=>$id, RO=>$ro);
5054             $idcnt++;
5055         }
5056         $clcnt++;
5057     }
5058     unless ($clcnt) { # sanity check
5059         $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
5060         return;
5061     }
5062     if ($idcnt < 1000) {
5063         $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
5064                                  "in $metadata_file\n");
5065         return;
5066     }
5067     $CPAN::META->{PROTOCOL} ||=
5068         $cache->{PROTOCOL}; # reading does not up or downgrade, but it
5069                             # does initialize to some protocol
5070     $LAST_TIME = $cache->{last_time};
5071     $DATE_OF_02 = $cache->{DATE_OF_02};
5072     $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
5073         if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
5074     return;
5075 }
5076
5077 package CPAN::InfoObj;
5078 use strict;
5079
5080 sub ro {
5081     my $self = shift;
5082     exists $self->{RO} and return $self->{RO};
5083 }
5084
5085 #-> sub CPAN::InfoObj::cpan_userid
5086 sub cpan_userid {
5087     my $self = shift;
5088     my $ro = $self->ro;
5089     if ($ro) {
5090         return $ro->{CPAN_USERID} || "N/A";
5091     } else {
5092         $self->debug("ID[$self->{ID}]");
5093         # N/A for bundles found locally
5094         return "N/A";
5095     }
5096 }
5097
5098 sub id { shift->{ID}; }
5099
5100 #-> sub CPAN::InfoObj::new ;
5101 sub new {
5102     my $this = bless {}, shift;
5103     %$this = @_;
5104     $this
5105 }
5106
5107 # The set method may only be used by code that reads index data or
5108 # otherwise "objective" data from the outside world. All session
5109 # related material may do anything else with instance variables but
5110 # must not touch the hash under the RO attribute. The reason is that
5111 # the RO hash gets written to Metadata file and is thus persistent.
5112
5113 #-> sub CPAN::InfoObj::safe_chdir ;
5114 sub safe_chdir {
5115   my($self,$todir) = @_;
5116   # we die if we cannot chdir and we are debuggable
5117   Carp::confess("safe_chdir called without todir argument")
5118         unless defined $todir and length $todir;
5119   if (chdir $todir) {
5120     $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5121         if $CPAN::DEBUG;
5122   } else {
5123     if (-e $todir) {
5124         unless (-x $todir) {
5125             unless (chmod 0755, $todir) {
5126                 my $cwd = CPAN::anycwd();
5127                 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
5128                                         "permission to change the permission; cannot ".
5129                                         "chdir to '$todir'\n");
5130                 $CPAN::Frontend->mysleep(5);
5131                 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5132                                        qq{to todir[$todir]: $!});
5133             }
5134         }
5135     } else {
5136         $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
5137     }
5138     if (chdir $todir) {
5139       $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
5140           if $CPAN::DEBUG;
5141     } else {
5142       my $cwd = CPAN::anycwd();
5143       $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
5144                              qq{to todir[$todir] (a chmod has been issued): $!});
5145     }
5146   }
5147 }
5148
5149 #-> sub CPAN::InfoObj::set ;
5150 sub set {
5151     my($self,%att) = @_;
5152     my $class = ref $self;
5153
5154     # This must be ||=, not ||, because only if we write an empty
5155     # reference, only then the set method will write into the readonly
5156     # area. But for Distributions that spring into existence, maybe
5157     # because of a typo, we do not like it that they are written into
5158     # the readonly area and made permanent (at least for a while) and
5159     # that is why we do not "allow" other places to call ->set.
5160     unless ($self->id) {
5161         CPAN->debug("Bug? Empty ID, rejecting");
5162         return;
5163     }
5164     my $ro = $self->{RO} =
5165         $CPAN::META->{readonly}{$class}{$self->id} ||= {};
5166
5167     while (my($k,$v) = each %att) {
5168         $ro->{$k} = $v;
5169     }
5170 }
5171
5172 #-> sub CPAN::InfoObj::as_glimpse ;
5173 sub as_glimpse {
5174     my($self) = @_;
5175     my(@m);
5176     my $class = ref($self);
5177     $class =~ s/^CPAN:://;
5178     my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
5179     push @m, sprintf "%-15s %s\n", $class, $id;
5180     join "", @m;
5181 }
5182
5183 #-> sub CPAN::InfoObj::as_string ;
5184 sub as_string {
5185     my($self) = @_;
5186     my(@m);
5187     my $class = ref($self);
5188     $class =~ s/^CPAN:://;
5189     push @m, $class, " id = $self->{ID}\n";
5190     my $ro;
5191     unless ($ro = $self->ro) {
5192         if (substr($self->{ID},-1,1) eq ".") { # directory
5193             $ro = +{};
5194         } else {
5195             $CPAN::Frontend->mydie("Unknown object $self->{ID}");
5196         }
5197     }
5198     for (sort keys %$ro) {
5199         # next if m/^(ID|RO)$/;
5200         my $extra = "";
5201         if ($_ eq "CPAN_USERID") {
5202             $extra .= " (";
5203             $extra .= $self->fullname;
5204             my $email; # old perls!
5205             if ($email = $CPAN::META->instance("CPAN::Author",
5206                                                $self->cpan_userid
5207                                               )->email) {
5208                 $extra .= " <$email>";
5209             } else {
5210                 $extra .= " <no email>";
5211             }
5212             $extra .= ")";
5213         } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
5214             push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
5215             next;
5216         }
5217         next unless defined $ro->{$_};
5218         push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
5219     }
5220   KEY: for (sort keys %$self) {
5221         next if m/^(ID|RO)$/;
5222         unless (defined $self->{$_}) {
5223             delete $self->{$_};
5224             next KEY;
5225         }
5226         if (ref($self->{$_}) eq "ARRAY") {
5227           push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
5228         } elsif (ref($self->{$_}) eq "HASH") {
5229             my $value;
5230             if (/^CONTAINSMODS$/) {
5231                 $value = join(" ",sort keys %{$self->{$_}});
5232             } elsif (/^prereq_pm$/) {
5233                 my @value;
5234                 my $v = $self->{$_};
5235                 for my $x (sort keys %$v) {
5236                     my @svalue;
5237                     for my $y (sort keys %{$v->{$x}}) {
5238                         push @svalue, "$y=>$v->{$x}{$y}";
5239                     }
5240                     push @value, "$x\:" . join ",", @svalue if @svalue;
5241                 }
5242                 $value = join ";", @value;
5243             } else {
5244                 $value = $self->{$_};
5245             }
5246           push @m, sprintf(
5247                            "    %-12s %s\n",
5248                            $_,
5249                            $value,
5250                           );
5251         } else {
5252           push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
5253         }
5254     }
5255     join "", @m, "\n";
5256 }
5257
5258 #-> sub CPAN::InfoObj::fullname ;
5259 sub fullname {
5260     my($self) = @_;
5261     $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
5262 }
5263
5264 #-> sub CPAN::InfoObj::dump ;
5265 sub dump {
5266   my($self, $what) = @_;
5267   unless ($CPAN::META->has_inst("Data::Dumper")) {
5268       $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
5269   }
5270   local $Data::Dumper::Sortkeys;
5271   $Data::Dumper::Sortkeys = 1;
5272   my $out = Data::Dumper::Dumper($what ? eval $what : $self);
5273   if (length $out > 100000) {
5274       my $fh_pager = FileHandle->new;
5275       local($SIG{PIPE}) = "IGNORE";
5276       my $pager = $CPAN::Config->{'pager'} || "cat";
5277       $fh_pager->open("|$pager")
5278           or die "Could not open pager $pager\: $!";
5279       $fh_pager->print($out);
5280       close $fh_pager;
5281   } else {
5282       $CPAN::Frontend->myprint($out);
5283   }
5284 }
5285
5286 package CPAN::Author;
5287 use strict;
5288
5289 #-> sub CPAN::Author::force
5290 sub force {
5291     my $self = shift;
5292     $self->{force}++;
5293 }
5294
5295 #-> sub CPAN::Author::force
5296 sub unforce {
5297     my $self = shift;
5298     delete $self->{force};
5299 }
5300
5301 #-> sub CPAN::Author::id
5302 sub id {
5303     my $self = shift;
5304     my $id = $self->{ID};
5305     $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
5306     $id;
5307 }
5308
5309 #-> sub CPAN::Author::as_glimpse ;
5310 sub as_glimpse {
5311     my($self) = @_;
5312     my(@m);
5313     my $class = ref($self);
5314     $class =~ s/^CPAN:://;
5315     push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
5316                      $class,
5317                      $self->{ID},
5318                      $self->fullname,
5319                      $self->email);
5320     join "", @m;
5321 }
5322
5323 #-> sub CPAN::Author::fullname ;
5324 sub fullname {
5325     shift->ro->{FULLNAME};
5326 }
5327 *name = \&fullname;
5328
5329 #-> sub CPAN::Author::email ;
5330 sub email    { shift->ro->{EMAIL}; }
5331
5332 #-> sub CPAN::Author::ls ;
5333 sub ls {
5334     my $self = shift;
5335     my $glob = shift || "";
5336     my $silent = shift || 0;
5337     my $id = $self->id;
5338
5339     # adapted from CPAN::Distribution::verifyCHECKSUM ;
5340     my(@csf); # chksumfile
5341     @csf = $self->id =~ /(.)(.)(.*)/;
5342     $csf[1] = join "", @csf[0,1];
5343     $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
5344     my(@dl);
5345     @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
5346     unless (grep {$_->[2] eq $csf[1]} @dl) {
5347         $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
5348         return;
5349     }
5350     @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
5351     unless (grep {$_->[2] eq $csf[2]} @dl) {
5352         $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
5353         return;
5354     }
5355     @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
5356     if ($glob) {
5357         if ($CPAN::META->has_inst("Text::Glob")) {
5358             my $rglob = Text::Glob::glob_to_regex($glob);
5359             @dl = grep { $_->[2] =~ /$rglob/ } @dl;
5360         } else {
5361             $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
5362         }
5363     }
5364     $CPAN::Frontend->myprint(join "", map {
5365         sprintf("%8d %10s %s/%s\n", $_->[0], $_->[1], $id, $_->[2])
5366     } sort { $a->[2] cmp $b->[2] } @dl);
5367     @dl;
5368 }
5369
5370 # returns an array of arrays, the latter contain (size,mtime,filename)
5371 #-> sub CPAN::Author::dir_listing ;
5372 sub dir_listing {
5373     my $self = shift;
5374     my $chksumfile = shift;
5375     my $recursive = shift;
5376     my $may_ftp = shift;
5377
5378     my $lc_want =
5379         File::Spec->catfile($CPAN::Config->{keep_source_where},
5380                             "authors", "id", @$chksumfile);
5381
5382     my $fh;
5383
5384     # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
5385     # hazard.  (Without GPG installed they are not that much better,
5386     # though.)
5387     $fh = FileHandle->new;
5388     if (open($fh, $lc_want)) {
5389         my $line = <$fh>; close $fh;
5390         unlink($lc_want) unless $line =~ /PGP/;
5391     }
5392
5393     local($") = "/";
5394     # connect "force" argument with "index_expire".
5395     my $force = $self->{force};
5396     if (my @stat = stat $lc_want) {
5397         $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
5398     }
5399     my $lc_file;
5400     if ($may_ftp) {
5401         $lc_file = CPAN::FTP->localize(
5402                                        "authors/id/@$chksumfile",
5403                                        $lc_want,
5404                                        $force,
5405                                       );
5406         unless ($lc_file) {
5407             $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
5408             $chksumfile->[-1] .= ".gz";
5409             $lc_file = CPAN::FTP->localize("authors/id/@$chksumfile",
5410                                            "$lc_want.gz",1);
5411             if ($lc_file) {
5412                 $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
5413                 eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
5414             } else {
5415                 return;
5416             }
5417         }
5418     } else {
5419         $lc_file = $lc_want;
5420         # we *could* second-guess and if the user has a file: URL,
5421         # then we could look there. But on the other hand, if they do
5422         # have a file: URL, wy did they choose to set
5423         # $CPAN::Config->{show_upload_date} to false?
5424     }
5425
5426     # adapted from CPAN::Distribution::CHECKSUM_check_file ;
5427     $fh = FileHandle->new;
5428     my($cksum);
5429     if (open $fh, $lc_file){
5430         local($/);
5431         my $eval = <$fh>;
5432         $eval =~ s/\015?\012/\n/g;
5433         close $fh;
5434         my($comp) = Safe->new();
5435         $cksum = $comp->reval($eval);
5436         if ($@) {
5437             rename $lc_file, "$lc_file.bad";
5438             Carp::confess($@) if $@;
5439         }
5440     } elsif ($may_ftp) {
5441         Carp::carp "Could not open '$lc_file' for reading.";
5442     } else {
5443         # Maybe should warn: "You may want to set show_upload_date to a true value"
5444         return;
5445     }
5446     my(@result,$f);
5447     for $f (sort keys %$cksum) {
5448         if (exists $cksum->{$f}{isdir}) {
5449             if ($recursive) {
5450                 my(@dir) = @$chksumfile;
5451                 pop @dir;
5452                 push @dir, $f, "CHECKSUMS";
5453                 push @result, map {
5454                     [$_->[0], $_->[1], "$f/$_->[2]"]
5455                 } $self->dir_listing(\@dir,1,$may_ftp);
5456             } else {
5457                 push @result, [ 0, "-", $f ];
5458             }
5459         } else {
5460             push @result, [
5461                            ($cksum->{$f}{"size"}||0),
5462                            $cksum->{$f}{"mtime"}||"---",
5463                            $f
5464                           ];
5465         }
5466     }
5467     @result;
5468 }
5469
5470 package CPAN::Distribution;
5471 use strict;
5472
5473 # Accessors
5474 sub cpan_comment {
5475     my $self = shift;
5476     my $ro = $self->ro or return;
5477     $ro->{CPAN_COMMENT}
5478 }
5479
5480 # CPAN::Distribution::undelay
5481 sub undelay {
5482     my $self = shift;
5483     delete $self->{later};
5484 }
5485
5486 # add the A/AN/ stuff
5487 # CPAN::Distribution::normalize
5488 sub normalize {
5489     my($self,$s) = @_;
5490     $s = $self->id unless defined $s;
5491     if (substr($s,-1,1) eq ".") {
5492         # using a global because we are sometimes called as static method
5493         if (!$CPAN::META->{LOCK}
5494             && !$CPAN::Have_warned->{"$s is unlocked"}++
5495            ) {
5496             $CPAN::Frontend->mywarn("You are visiting the local directory
5497   '$s'
5498   without lock, take care that concurrent processes do not do likewise.\n");
5499             $CPAN::Frontend->mysleep(1);
5500         }
5501         if ($s eq ".") {
5502             $s = "$CPAN::iCwd/.";
5503         } elsif (File::Spec->file_name_is_absolute($s)) {
5504         } elsif (File::Spec->can("rel2abs")) {
5505             $s = File::Spec->rel2abs($s);
5506         } else {
5507             $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
5508         }
5509         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5510         unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
5511             for ($CPAN::META->instance("CPAN::Distribution", $s)) {
5512                 $_->{build_dir} = $s;
5513                 $_->{archived} = "local_directory";
5514                 $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
5515             }
5516         }
5517     } elsif (
5518         $s =~ tr|/|| == 1
5519         or
5520         $s !~ m|[A-Z]/[A-Z-]{2}/[A-Z-]{2,}/|
5521        ) {
5522         return $s if $s =~ m:^N/A|^Contact Author: ;
5523         $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4| or
5524             $CPAN::Frontend->mywarn("Strange distribution name [$s]\n");
5525         CPAN->debug("s[$s]") if $CPAN::DEBUG;
5526     }
5527     $s;
5528 }
5529
5530 #-> sub CPAN::Distribution::author ;
5531 sub author {
5532     my($self) = @_;
5533     my($authorid);
5534     if (substr($self->id,-1,1) eq ".") {
5535         $authorid = "LOCAL";
5536     } else {
5537         ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
5538     }
5539     CPAN::Shell->expand("Author",$authorid);
5540 }
5541
5542 # tries to get the yaml from CPAN instead of the distro itself:
5543 # EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
5544 sub fast_yaml {
5545     my($self) = @_;
5546     my $meta = $self->pretty_id;
5547     $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
5548     my(@ls) = CPAN::Shell->globls($meta);
5549     my $norm = $self->normalize($meta);
5550
5551     my($local_file);
5552     my($local_wanted) =
5553         File::Spec->catfile(
5554                             $CPAN::Config->{keep_source_where},
5555                             "authors",
5556                             "id",
5557                             split(/\//,$norm)
5558                            );
5559     $self->debug("Doing localize") if $CPAN::DEBUG;
5560     unless ($local_file =
5561             CPAN::FTP->localize("authors/id/$norm",
5562                                 $local_wanted)) {
5563         $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
5564     }
5565     my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
5566 }
5567
5568 #-> sub CPAN::Distribution::cpan_userid
5569 sub cpan_userid {
5570     my $self = shift;
5571     if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
5572         return $1;
5573     }
5574     return $self->SUPER::cpan_userid;
5575 }
5576
5577 #-> sub CPAN::Distribution::pretty_id
5578 sub pretty_id {
5579     my $self = shift;
5580     my $id = $self->id;
5581     return $id unless $id =~ m|^./../|;
5582     substr($id,5);
5583 }
5584
5585 # mark as dirty/clean for the sake of recursion detection. $color=1
5586 # means "in use", $color=0 means "not in use anymore". $color=2 means
5587 # we have determined prereqs now and thus insist on passing this
5588 # through (at least) once again.
5589
5590 #-> sub CPAN::Distribution::color_cmd_tmps ;
5591 sub color_cmd_tmps {
5592     my($self) = shift;
5593     my($depth) = shift || 0;
5594     my($color) = shift || 0;
5595     my($ancestors) = shift || [];
5596     # a distribution needs to recurse into its prereq_pms
5597
5598     return if exists $self->{incommandcolor}
5599         && $color==1
5600         && $self->{incommandcolor}==$color;
5601     if ($depth>=$CPAN::MAX_RECURSION){
5602         die(CPAN::Exception::RecursiveDependency->new($ancestors));
5603     }
5604     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
5605     my $prereq_pm = $self->prereq_pm;
5606     if (defined $prereq_pm) {
5607       PREREQ: for my $pre (keys %{$prereq_pm->{requires}||{}},
5608                            keys %{$prereq_pm->{build_requires}||{}}) {
5609             next PREREQ if $pre eq "perl";
5610             my $premo;
5611             unless ($premo = CPAN::Shell->expand("Module",$pre)) {
5612                 $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
5613                 $CPAN::Frontend->mysleep(2);
5614                 next PREREQ;
5615             }
5616             $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
5617         }
5618     }
5619     if ($color==0) {
5620         delete $self->{sponsored_mods};
5621
5622         # as we are at the end of a command, we'll give up this
5623         # reminder of a broken test. Other commands may test this guy
5624         # again. Maybe 'badtestcnt' should be renamed to
5625         # 'make_test_failed_within_command'?
5626         delete $self->{badtestcnt};
5627     }
5628     $self->{incommandcolor} = $color;
5629 }
5630
5631 #-> sub CPAN::Distribution::as_string ;
5632 sub as_string {
5633   my $self = shift;
5634   $self->containsmods;
5635   $self->upload_date;
5636   $self->SUPER::as_string(@_);
5637 }
5638
5639 #-> sub CPAN::Distribution::containsmods ;
5640 sub containsmods {
5641   my $self = shift;
5642   return keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
5643   my $dist_id = $self->{ID};
5644   for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
5645     my $mod_file = $mod->cpan_file or next;
5646     my $mod_id = $mod->{ID} or next;
5647     # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
5648     # sleep 1;
5649     if ($CPAN::Signal) {
5650         delete $self->{CONTAINSMODS};
5651         return;
5652     }
5653     $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
5654   }
5655   keys %{$self->{CONTAINSMODS}||{}};
5656 }
5657
5658 #-> sub CPAN::Distribution::upload_date ;
5659 sub upload_date {
5660   my $self = shift;
5661   return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
5662   my(@local_wanted) = split(/\//,$self->id);
5663   my $filename = pop @local_wanted;
5664   push @local_wanted, "CHECKSUMS";
5665   my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
5666   return unless $author;
5667   my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
5668   return unless @dl;
5669   my($dirent) = grep { $_->[2] eq $filename } @dl;
5670   # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
5671   return unless $dirent->[1];
5672   return $self->{UPLOAD_DATE} = $dirent->[1];
5673 }
5674
5675 #-> sub CPAN::Distribution::uptodate ;
5676 sub uptodate {
5677     my($self) = @_;
5678     my $c;
5679     foreach $c ($self->containsmods) {
5680         my $obj = CPAN::Shell->expandany($c);
5681         unless ($obj->uptodate){
5682             my $id = $self->pretty_id;
5683             $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
5684             return 0;
5685         }
5686     }
5687     return 1;
5688 }
5689
5690 #-> sub CPAN::Distribution::called_for ;
5691 sub called_for {
5692     my($self,$id) = @_;
5693     $self->{CALLED_FOR} = $id if defined $id;
5694     return $self->{CALLED_FOR};
5695 }
5696
5697 #-> sub CPAN::Distribution::get ;
5698 sub get {
5699     my($self) = @_;
5700     $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
5701     if (my $goto = $self->prefs->{goto}) {
5702         $CPAN::Frontend->mywarn
5703             (sprintf(
5704                      "delegating to '%s' as specified in prefs file '%s' doc %d\n",
5705                      $goto,
5706                      $self->{prefs_file},
5707                      $self->{prefs_file_doc},
5708                     ));
5709         return $self->goto($goto);
5710     }
5711     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
5712                            ? $ENV{PERL5LIB}
5713                            : ($ENV{PERLLIB} || "");
5714
5715     $CPAN::META->set_perl5lib;
5716     local $ENV{MAKEFLAGS}; # protect us from outer make calls
5717
5718   EXCUSE: {
5719         my @e;
5720         $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
5721         if ($self->prefs->{disabled}) {
5722             my $why = sprintf(
5723                               "Disabled via prefs file '%s' doc %d",
5724                               $self->{prefs_file},
5725                               $self->{prefs_file_doc},
5726                              );
5727             push @e, $why;
5728             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $why");
5729             # note: not intended to be persistent but at least visible
5730             # during this session
5731         } else {
5732             if (exists $self->{build_dir} && -d $self->{build_dir}) {
5733                 # this deserves print, not warn:
5734                 $CPAN::Frontend->myprint("  Has already been unwrapped into directory ".
5735                                          "$self->{build_dir}\n"
5736                                         );
5737                 return 1;
5738             }
5739
5740             # although we talk about 'force' we shall not test on
5741             # force directly. New model of force tries to refrain from
5742             # direct checking of force.
5743             exists $self->{unwrapped} and (
5744                                            UNIVERSAL::can($self->{unwrapped},"failed") ?
5745                                            $self->{unwrapped}->failed :
5746                                            $self->{unwrapped} =~ /^NO/
5747                                           )
5748                 and push @e, "Unwrapping had some problem, won't try again without force";
5749         }
5750
5751         $CPAN::Frontend->mywarn(join "", map {"$_\n"} @e) and return if @e;
5752     }
5753     my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible
5754
5755     #
5756     # Get the file on local disk
5757     #
5758
5759     my($local_file);
5760     my($local_wanted) =
5761         File::Spec->catfile(
5762                             $CPAN::Config->{keep_source_where},
5763                             "authors",
5764                             "id",
5765                             split(/\//,$self->id)
5766                            );
5767
5768     $self->debug("Doing localize") if $CPAN::DEBUG;
5769     unless ($local_file =
5770             CPAN::FTP->localize("authors/id/$self->{ID}",
5771                                 $local_wanted)) {
5772         my $note = "";
5773         if ($CPAN::Index::DATE_OF_02) {
5774             $note = "Note: Current database in memory was generated ".
5775                 "on $CPAN::Index::DATE_OF_02\n";
5776         }
5777         $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
5778     }
5779
5780     $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
5781     $self->{localfile} = $local_file;
5782     return if $CPAN::Signal;
5783
5784     #
5785     # Check integrity
5786     #
5787     if ($CPAN::META->has_inst("Digest::SHA")) {
5788         $self->debug("Digest::SHA is installed, verifying");
5789         $self->verifyCHECKSUM;
5790     } else {
5791         $self->debug("Digest::SHA is NOT installed");
5792     }
5793     return if $CPAN::Signal;
5794
5795     #
5796     # Create a clean room and go there
5797     #
5798     $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
5799     my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
5800     $self->safe_chdir($builddir);
5801     $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
5802     File::Path::rmtree("tmp-$$");
5803     unless (mkdir "tmp-$$", 0755) {
5804         $CPAN::Frontend->unrecoverable_error(<<EOF);
5805 Couldn't mkdir '$builddir/tmp-$$': $!
5806
5807 Cannot continue: Please find the reason why I cannot make the
5808 directory
5809 $builddir/tmp-$$
5810 and fix the problem, then retry.
5811
5812 EOF
5813     }
5814     if ($CPAN::Signal){
5815         $self->safe_chdir($sub_wd);
5816         return;
5817     }
5818     $self->safe_chdir("tmp-$$");
5819
5820     #
5821     # Unpack the goods
5822     #
5823     my $ct = eval{CPAN::Tarzip->new($local_file)};
5824     unless ($ct) {
5825         $self->{unwrapped} = CPAN::Distrostatus->new("NO");
5826         delete $self->{build_dir};
5827         return;
5828     }
5829     if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i){
5830         $self->{was_uncompressed}++ unless eval{$ct->gtest()};
5831         $self->untar_me($ct);
5832     } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
5833         $self->unzip_me($ct);
5834     } else {
5835         $self->{was_uncompressed}++ unless $ct->gtest();
5836         $local_file = $self->handle_singlefile($local_file);
5837     }
5838
5839     # we are still in the tmp directory!
5840     # Let's check if the package has its own directory.
5841     my $dh = DirHandle->new(File::Spec->curdir)
5842         or Carp::croak("Couldn't opendir .: $!");
5843     my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
5844     $dh->close;
5845     my ($packagedir);
5846     # XXX here we want in each branch File::Temp to protect all build_dir directories
5847     if (CPAN->has_inst("File::Temp")) {
5848         my $tdir_base;
5849         my $from_dir;
5850         my @dirents;
5851         if (@readdir == 1 && -d $readdir[0]) {
5852             $tdir_base = $readdir[0];
5853             $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
5854             my $dh2 = DirHandle->new($from_dir)
5855                 or Carp::croak("Couldn't opendir $from_dir: $!");
5856             @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
5857         } else {
5858             my $userid = $self->cpan_userid;
5859             CPAN->debug("userid[$userid]");
5860             if (!$userid or $userid eq "N/A") {
5861                 $userid = "anon";
5862             }
5863             $tdir_base = $userid;
5864             $from_dir = File::Spec->curdir;
5865             @dirents = @readdir;
5866         }
5867         $packagedir = File::Temp::tempdir(
5868                                           "$tdir_base-XXXXXX",
5869                                           DIR => $builddir,
5870                                           CLEANUP => 0,
5871                                          );
5872         my $f;
5873         for $f (@dirents) { # is already without "." and ".."
5874             my $from = File::Spec->catdir($from_dir,$f);
5875             my $to = File::Spec->catdir($packagedir,$f);
5876             unless (File::Copy::move($from,$to)) {
5877                 my $err = $!;
5878                 $from = File::Spec->rel2abs($from);
5879                 Carp::confess("Couldn't move $from to $to: $err");
5880             }
5881         }
5882     } else { # older code below, still better than nothing when there is no File::Temp
5883         my($distdir);
5884         if (@readdir == 1 && -d $readdir[0]) {
5885             $distdir = $readdir[0];
5886             $packagedir = File::Spec->catdir($builddir,$distdir);
5887             $self->debug("packagedir[$packagedir]builddir[$builddir]distdir[$distdir]")
5888                 if $CPAN::DEBUG;
5889             -d $packagedir and $CPAN::Frontend->myprint("Removing previously used ".
5890                                                         "$packagedir\n");
5891             File::Path::rmtree($packagedir);
5892             unless (File::Copy::move($distdir,$packagedir)) {
5893                 $CPAN::Frontend->unrecoverable_error(<<EOF);
5894 Couldn't move '$distdir' to '$packagedir': $!
5895
5896 Cannot continue: Please find the reason why I cannot move
5897 $builddir/tmp-$$/$distdir
5898 to
5899 $packagedir
5900 and fix the problem, then retry
5901
5902 EOF
5903             }
5904             $self->debug(sprintf("moved distdir[%s] to packagedir[%s] -e[%s]-d[%s]",
5905                                  $distdir,
5906                                  $packagedir,
5907                                  -e $packagedir,
5908                                  -d $packagedir,
5909                                 )) if $CPAN::DEBUG;
5910         } else {
5911             my $userid = $self->cpan_userid;
5912             CPAN->debug("userid[$userid]") if $CPAN::DEBUG;
5913             if (!$userid or $userid eq "N/A") {
5914                 $userid = "anon";
5915             }
5916             my $pragmatic_dir = $userid . '000';
5917             $pragmatic_dir =~ s/\W_//g;
5918             $pragmatic_dir++ while -d "../$pragmatic_dir";
5919             $packagedir = File::Spec->catdir($builddir,$pragmatic_dir);
5920             $self->debug("packagedir[$packagedir]") if $CPAN::DEBUG;
5921             File::Path::mkpath($packagedir);
5922             my($f);
5923             for $f (@readdir) { # is already without "." and ".."
5924                 my $to = File::Spec->catdir($packagedir,$f);
5925                 File::Copy::move($f,$to) or Carp::confess("Couldn't move $f to $to: $!");
5926             }
5927         }
5928     }
5929     if ($CPAN::Signal){
5930         $self->safe_chdir($sub_wd);
5931         return;
5932     }
5933
5934     $self->{build_dir} = $packagedir;
5935     $self->safe_chdir($builddir);
5936     File::Path::rmtree("tmp-$$");
5937
5938     $self->safe_chdir($packagedir);
5939     $self->_signature_business();
5940     $self->safe_chdir($builddir);
5941     return if $CPAN::Signal;
5942
5943
5944     my($mpl) = File::Spec->catfile($packagedir,"Makefile.PL");
5945     my($mpl_exists) = -f $mpl;
5946     unless ($mpl_exists) {
5947         # NFS has been reported to have racing problems after the
5948         # renaming of a directory in some environments.
5949         # This trick helps.
5950         $CPAN::Frontend->mysleep(1);
5951         my $mpldh = DirHandle->new($packagedir)
5952             or Carp::croak("Couldn't opendir $packagedir: $!");
5953         $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
5954         $mpldh->close;
5955     }
5956     my $prefer_installer = "eumm"; # eumm|mb
5957     if (-f File::Spec->catfile($packagedir,"Build.PL")) {
5958         if ($mpl_exists) { # they *can* choose
5959             if ($CPAN::META->has_inst("Module::Build")) {
5960                 $prefer_installer = CPAN::HandleConfig->prefs_lookup($self,
5961                                                                      q{prefer_installer});
5962             }
5963         } else {
5964             $prefer_installer = "mb";
5965         }
5966     }
5967     return unless $self->patch;
5968     if (lc($prefer_installer) eq "mb") {
5969         $self->{modulebuild} = 1;
5970     } elsif ($self->{archived} eq "patch") {
5971         # not an edge case, nothing to install for sure
5972         my $why = "A patch file cannot be installed";
5973         $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
5974         $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
5975     } elsif (! $mpl_exists) {
5976         $self->_edge_cases($mpl,$packagedir,$local_file);
5977     }
5978     if ($self->{build_dir}
5979         &&
5980         $CPAN::Config->{build_dir_reuse}
5981        ) {
5982         $self->store_persistent_state;
5983     }
5984
5985     return $self;
5986 }
5987
5988 #-> CPAN::Distribution::store_persistent_state
5989 sub store_persistent_state {
5990     my($self) = @_;
5991     my $dir = $self->{build_dir};
5992     unless (File::Spec->canonpath(File::Basename::dirname($dir))
5993             eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
5994         $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
5995                                 "will not store persistent state\n");
5996         return;
5997     }
5998     my $file = sprintf "%s.yml", $dir;
5999     my $yaml_module = CPAN::_yaml_module;
6000     if ($CPAN::META->has_inst($yaml_module)) {
6001         CPAN->_yaml_dumpfile(
6002                              $file,
6003                              {
6004                               time => time,
6005                               perl => CPAN::_perl_fingerprint,
6006                               distribution => $self,
6007                              }
6008                             );
6009     } else {
6010         $CPAN::Frontend->myprint("Warning (usually harmless): '$yaml_module' not installed, ".
6011                                 "will not store persistent state\n");
6012     }
6013 }
6014
6015 #-> CPAN::Distribution::patch
6016 sub try_download {
6017     my($self,$patch) = @_;
6018     my $norm = $self->normalize($patch);
6019     my($local_wanted) =
6020         File::Spec->catfile(
6021                             $CPAN::Config->{keep_source_where},
6022                             "authors",
6023                             "id",
6024                             split(/\//,$norm),
6025                             );
6026     $self->debug("Doing localize") if $CPAN::DEBUG;
6027     return CPAN::FTP->localize("authors/id/$norm",
6028                                $local_wanted);
6029 }
6030
6031 #-> CPAN::Distribution::patch
6032 sub patch {
6033     my($self) = @_;
6034     $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
6035     my $patches = $self->prefs->{patches};
6036     $patches ||= "";
6037     $self->debug("patches[$patches]") if $CPAN::DEBUG;
6038     if ($patches) {
6039         return unless @$patches;
6040         $self->safe_chdir($self->{build_dir});
6041         CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
6042         my $patchbin = $CPAN::Config->{patch};
6043         unless ($patchbin && length $patchbin) {
6044             $CPAN::Frontend->mydie("No external patch command configured\n\n".
6045                                    "Please run 'o conf init /patch/'\n\n");
6046         }
6047         unless (MM->maybe_command($patchbin)) {
6048             $CPAN::Frontend->mydie("No external patch command available\n\n".
6049                                    "Please run 'o conf init /patch/'\n\n");
6050         }
6051         $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
6052         local $ENV{PATCH_GET} = 0; # shall replace -g0 which is not
6053                                    # supported everywhere (and then,
6054                                    # not ever necessary there)
6055         my $stdpatchargs = "-N --fuzz=3";
6056         my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
6057         $CPAN::Frontend->myprint("Going to apply $countedpatches:\n");
6058         for my $patch (@$patches) {
6059             unless (-f $patch) {
6060                 if (my $trydl = $self->try_download($patch)) {
6061                     $patch = $trydl;
6062                 } else {
6063                     my $fail = "Could not find patch '$patch'";
6064                     $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6065                     $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6066                     delete $self->{build_dir};
6067                     return;
6068                 }
6069             }
6070             $CPAN::Frontend->myprint("  $patch\n");
6071             my $readfh = CPAN::Tarzip->TIEHANDLE($patch);
6072
6073             my $pcommand;
6074             my $ppp = $self->_patch_p_parameter($readfh);
6075             if ($ppp eq "applypatch") {
6076                 $pcommand = "$CPAN::Config->{applypatch} -verbose";
6077             } else {
6078                 my $thispatchargs = join " ", $stdpatchargs, $ppp;
6079                 $pcommand = "$patchbin $thispatchargs";
6080             }
6081
6082             $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
6083             my $writefh = FileHandle->new;
6084             $CPAN::Frontend->myprint("  $pcommand\n");
6085             unless (open $writefh, "|$pcommand") {
6086                 my $fail = "Could not fork '$pcommand'";
6087                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6088                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6089                 delete $self->{build_dir};
6090                 return;
6091             }
6092             while (my $x = $readfh->READLINE) {
6093                 print $writefh $x;
6094             }
6095             unless (close $writefh) {
6096                 my $fail = "Could not apply patch '$patch'";
6097                 $CPAN::Frontend->mywarn("$fail; cannot continue\n");
6098                 $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
6099                 delete $self->{build_dir};
6100                 return;
6101             }
6102         }
6103         $self->{patched}++;
6104     }
6105     return 1;
6106 }
6107
6108 sub _patch_p_parameter {
6109     my($self,$fh) = @_;
6110     my $cnt_files   = 0;
6111     my $cnt_p0files = 0;
6112     local($_);
6113     while ($_ = $fh->READLINE) {
6114         if (
6115             $CPAN::Config->{applypatch}
6116             &&
6117             /\#\#\#\# ApplyPatch data follows \#\#\#\#/
6118            ) {
6119             return "applypatch"
6120         }
6121         next unless /^[\*\+]{3}\s(\S+)/;
6122         my $file = $1;
6123         $cnt_files++;
6124         $cnt_p0files++ if -f $file;
6125         CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
6126             if $CPAN::DEBUG;
6127     }
6128     return "-p1" unless $cnt_files;
6129     return $cnt_files==$cnt_p0files ? "-p0" : "-p1";
6130 }
6131
6132 #-> sub CPAN::Distribution::_edge_cases
6133 # with "configure" or "Makefile" or single file scripts
6134 sub _edge_cases {
6135     my($self,$mpl,$packagedir,$local_file) = @_;
6136     $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
6137                          $mpl,
6138                          CPAN::anycwd(),
6139                         )) if $CPAN::DEBUG;
6140     my($configure) = File::Spec->catfile($packagedir,"Configure");
6141     if (-f $configure) {
6142         # do we have anything to do?
6143         $self->{configure} = $configure;
6144     } elsif (-f File::Spec->catfile($packagedir,"Makefile")) {
6145         $CPAN::Frontend->mywarn(qq{
6146 Package comes with a Makefile and without a Makefile.PL.
6147 We\'ll try to build it with that Makefile then.
6148 });
6149         $self->{writemakefile} = CPAN::Distrostatus->new("YES");
6150         $CPAN::Frontend->mysleep(2);
6151     } else {
6152         my $cf = $self->called_for || "unknown";
6153         if ($cf =~ m|/|) {
6154             $cf =~ s|.*/||;
6155             $cf =~ s|\W.*||;
6156         }
6157         $cf =~ s|[/\\:]||g;     # risk of filesystem damage
6158         $cf = "unknown" unless length($cf);
6159         $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
6160   (The test -f "$mpl" returned false.)
6161   Writing one on our own (setting NAME to $cf)\a\n});
6162         $self->{had_no_makefile_pl}++;
6163         $CPAN::Frontend->mysleep(3);
6164
6165         # Writing our own Makefile.PL
6166
6167         my $script = "";
6168         if ($self->{archived} eq "maybe_pl") {
6169             my $fh = FileHandle->new;
6170             my $script_file = File::Spec->catfile($packagedir,$local_file);
6171             $fh->open($script_file)
6172                 or Carp::croak("Could not open $script_file: $!");
6173             local $/ = "\n";
6174             # name parsen und prereq
6175             my($state) = "poddir";
6176             my($name, $prereq) = ("", "");
6177             while (<$fh>) {
6178                 if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
6179                     if ($1 eq 'NAME') {
6180                         $state = "name";
6181                     } elsif ($1 eq 'PREREQUISITES') {
6182                         $state = "prereq";
6183                     }
6184                 } elsif ($state =~ m{^(name|prereq)$}) {
6185                     if (/^=/) {
6186                         $state = "poddir";
6187                     } elsif (/^\s*$/) {
6188                         # nop
6189                     } elsif ($state eq "name") {
6190                         if ($name eq "") {
6191                             ($name) = /^(\S+)/;
6192                             $state = "poddir";
6193                         }
6194                     } elsif ($state eq "prereq") {
6195                         $prereq .= $_;
6196                     }
6197                 } elsif (/^=cut\b/) {
6198                     last;
6199                 }
6200             }
6201             $fh->close;
6202
6203             for ($name) {
6204                 s{.*<}{};       # strip X<...>
6205                 s{>.*}{};
6206             }
6207             chomp $prereq;
6208             $prereq = join " ", split /\s+/, $prereq;
6209             my($PREREQ_PM) = join("\n", map {
6210                 s{.*<}{};       # strip X<...>
6211                 s{>.*}{};
6212                 if (/[\s\'\"]/) { # prose?
6213                 } else {
6214                     s/[^\w:]$//; # period?
6215                     " "x28 . "'$_' => 0,";
6216                 }
6217             } split /\s*,\s*/, $prereq);
6218
6219             $script = "
6220               EXE_FILES => ['$name'],
6221               PREREQ_PM => {
6222 $PREREQ_PM
6223                            },
6224 ";
6225             if ($name) {
6226                 my $to_file = File::Spec->catfile($packagedir, $name);
6227                 rename $script_file, $to_file
6228                     or die "Can't rename $script_file to $to_file: $!";
6229             }
6230         }
6231
6232         my $fh = FileHandle->new;
6233         $fh->open(">$mpl")
6234             or Carp::croak("Could not open >$mpl: $!");
6235         $fh->print(
6236                    qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
6237 # because there was no Makefile.PL supplied.
6238 # Autogenerated on: }.scalar localtime().qq{
6239
6240 use ExtUtils::MakeMaker;
6241 WriteMakefile(
6242               NAME => q[$cf],$script
6243              );
6244 });
6245         $fh->close;
6246     }
6247 }
6248
6249 #-> CPAN::Distribution::_signature_business
6250 sub _signature_business {
6251     my($self) = @_;
6252     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6253                                                       q{check_sigs});
6254     if ($check_sigs) {
6255         if ($CPAN::META->has_inst("Module::Signature")) {
6256             if (-f "SIGNATURE") {
6257                 $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6258                 my $rv = Module::Signature::verify();
6259                 if ($rv != Module::Signature::SIGNATURE_OK() and
6260                     $rv != Module::Signature::SIGNATURE_MISSING()) {
6261                     $CPAN::Frontend->mywarn(
6262                                             qq{\nSignature invalid for }.
6263                                             qq{distribution file. }.
6264                                             qq{Please investigate.\n\n}
6265                                            );
6266
6267                     my $wrap =
6268                         sprintf(qq{I'd recommend removing %s. Some error occured    }.
6269                                 qq{while checking its signature, so it could        }.
6270                                 qq{be invalid. Maybe you have configured            }.
6271                                 qq{your 'urllist' with a bad URL. Please check this }.
6272                                 qq{array with 'o conf urllist' and retry. Or        }.
6273                                 qq{examine the distribution in a subshell. Try
6274   look %s
6275 and run
6276   cpansign -v
6277 },
6278                                 $self->{localfile},
6279                                 $self->pretty_id,
6280                                );
6281                     $self->{signature_verify} = CPAN::Distrostatus->new("NO");
6282                     $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
6283                     $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
6284                 } else {
6285                     $self->{signature_verify} = CPAN::Distrostatus->new("YES");
6286                     $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
6287                 }
6288             } else {
6289                 $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
6290             }
6291         } else {
6292             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6293         }
6294     }
6295 }
6296
6297 #-> CPAN::Distribution::untar_me ;
6298 sub untar_me {
6299     my($self,$ct) = @_;
6300     $self->{archived} = "tar";
6301     if ($ct->untar()) {
6302         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6303     } else {
6304         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
6305     }
6306 }
6307
6308 # CPAN::Distribution::unzip_me ;
6309 sub unzip_me {
6310     my($self,$ct) = @_;
6311     $self->{archived} = "zip";
6312     if ($ct->unzip()) {
6313         $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6314     } else {
6315         $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed");
6316     }
6317     return;
6318 }
6319
6320 sub handle_singlefile {
6321     my($self,$local_file) = @_;
6322
6323     if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ){
6324         $self->{archived} = "pm";
6325     } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
6326         $self->{archived} = "patch";
6327     } else {
6328         $self->{archived} = "maybe_pl";
6329     }
6330
6331     my $to = File::Basename::basename($local_file);
6332     if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
6333         if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
6334             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6335         } else {
6336             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
6337         }
6338     } else {
6339         if (File::Copy::cp($local_file,".")) {
6340             $self->{unwrapped} = CPAN::Distrostatus->new("YES");
6341         } else {
6342             $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
6343         }
6344     }
6345     return $to;
6346 }
6347
6348 #-> sub CPAN::Distribution::new ;
6349 sub new {
6350     my($class,%att) = @_;
6351
6352     # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
6353
6354     my $this = { %att };
6355     return bless $this, $class;
6356 }
6357
6358 #-> sub CPAN::Distribution::look ;
6359 sub look {
6360     my($self) = @_;
6361
6362     if ($^O eq 'MacOS') {
6363       $self->Mac::BuildTools::look;
6364       return;
6365     }
6366
6367     if (  $CPAN::Config->{'shell'} ) {
6368         $CPAN::Frontend->myprint(qq{
6369 Trying to open a subshell in the build directory...
6370 });
6371     } else {
6372         $CPAN::Frontend->myprint(qq{
6373 Your configuration does not define a value for subshells.
6374 Please define it with "o conf shell <your shell>"
6375 });
6376         return;
6377     }
6378     my $dist = $self->id;
6379     my $dir;
6380     unless ($dir = $self->dir) {
6381         $self->get;
6382     }
6383     unless ($dir ||= $self->dir) {
6384         $CPAN::Frontend->mywarn(qq{
6385 Could not determine which directory to use for looking at $dist.
6386 });
6387         return;
6388     }
6389     my $pwd  = CPAN::anycwd();
6390     $self->safe_chdir($dir);
6391     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6392     {
6393         local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
6394         $ENV{CPAN_SHELL_LEVEL} += 1;
6395         my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});
6396         unless (system($shell) == 0) {
6397             my $code = $? >> 8;
6398             $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
6399         }
6400     }
6401     $self->safe_chdir($pwd);
6402 }
6403
6404 # CPAN::Distribution::cvs_import ;
6405 sub cvs_import {
6406     my($self) = @_;
6407     $self->get;
6408     my $dir = $self->dir;
6409
6410     my $package = $self->called_for;
6411     my $module = $CPAN::META->instance('CPAN::Module', $package);
6412     my $version = $module->cpan_version;
6413
6414     my $userid = $self->cpan_userid;
6415
6416     my $cvs_dir = (split /\//, $dir)[-1];
6417     $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
6418     my $cvs_root =
6419       $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
6420     my $cvs_site_perl =
6421       $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
6422     if ($cvs_site_perl) {
6423         $cvs_dir = "$cvs_site_perl/$cvs_dir";
6424     }
6425     my $cvs_log = qq{"imported $package $version sources"};
6426     $version =~ s/\./_/g;
6427     # XXX cvs: undocumented and unclear how it was meant to work
6428     my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
6429                "$cvs_dir", $userid, "v$version");
6430
6431     my $pwd  = CPAN::anycwd();
6432     chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});
6433
6434     $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
6435
6436     $CPAN::Frontend->myprint(qq{@cmd\n});
6437     system(@cmd) == 0 or
6438     # XXX cvs
6439         $CPAN::Frontend->mydie("cvs import failed");
6440     chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
6441 }
6442
6443 #-> sub CPAN::Distribution::readme ;
6444 sub readme {
6445     my($self) = @_;
6446     my($dist) = $self->id;
6447     my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
6448     $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
6449     my($local_file);
6450     my($local_wanted) =
6451          File::Spec->catfile(
6452                              $CPAN::Config->{keep_source_where},
6453                              "authors",
6454                              "id",
6455                              split(/\//,"$sans.readme"),
6456                             );
6457     $self->debug("Doing localize") if $CPAN::DEBUG;
6458     $local_file = CPAN::FTP->localize("authors/id/$sans.readme",
6459                                       $local_wanted)
6460         or $CPAN::Frontend->mydie(qq{No $sans.readme found});;
6461
6462     if ($^O eq 'MacOS') {
6463         Mac::BuildTools::launch_file($local_file);
6464         return;
6465     }
6466
6467     my $fh_pager = FileHandle->new;
6468     local($SIG{PIPE}) = "IGNORE";
6469     my $pager = $CPAN::Config->{'pager'} || "cat";
6470     $fh_pager->open("|$pager")
6471         or die "Could not open pager $pager\: $!";
6472     my $fh_readme = FileHandle->new;
6473     $fh_readme->open($local_file)
6474         or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
6475     $CPAN::Frontend->myprint(qq{
6476 Displaying file
6477   $local_file
6478 with pager "$pager"
6479 });
6480     $fh_pager->print(<$fh_readme>);
6481     $fh_pager->close;
6482 }
6483
6484 #-> sub CPAN::Distribution::verifyCHECKSUM ;
6485 sub verifyCHECKSUM {
6486     my($self) = @_;
6487   EXCUSE: {
6488         my @e;
6489         $self->{CHECKSUM_STATUS} ||= "";
6490         $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
6491         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6492     }
6493     my($lc_want,$lc_file,@local,$basename);
6494     @local = split(/\//,$self->id);
6495     pop @local;
6496     push @local, "CHECKSUMS";
6497     $lc_want =
6498         File::Spec->catfile($CPAN::Config->{keep_source_where},
6499                             "authors", "id", @local);
6500     local($") = "/";
6501     if (my $size = -s $lc_want) {
6502         $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
6503         if ($self->CHECKSUM_check_file($lc_want,1)) {
6504             return $self->{CHECKSUM_STATUS} = "OK";
6505         }
6506     }
6507     $lc_file = CPAN::FTP->localize("authors/id/@local",
6508                                    $lc_want,1);
6509     unless ($lc_file) {
6510         $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
6511         $local[-1] .= ".gz";
6512         $lc_file = CPAN::FTP->localize("authors/id/@local",
6513                                        "$lc_want.gz",1);
6514         if ($lc_file) {
6515             $lc_file =~ s/\.gz(?!\n)\Z//;
6516             eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
6517         } else {
6518             return;
6519         }
6520     }
6521     if ($self->CHECKSUM_check_file($lc_file)) {
6522         return $self->{CHECKSUM_STATUS} = "OK";
6523     }
6524 }
6525
6526 #-> sub CPAN::Distribution::SIG_check_file ;
6527 sub SIG_check_file {
6528     my($self,$chk_file) = @_;
6529     my $rv = eval { Module::Signature::_verify($chk_file) };
6530
6531     if ($rv == Module::Signature::SIGNATURE_OK()) {
6532         $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
6533         return $self->{SIG_STATUS} = "OK";
6534     } else {
6535         $CPAN::Frontend->myprint(qq{\nSignature invalid for }.
6536                                  qq{distribution file. }.
6537                                  qq{Please investigate.\n\n}.
6538                                  $self->as_string,
6539                                 $CPAN::META->instance(
6540                                                         'CPAN::Author',
6541                                                         $self->cpan_userid
6542                                                         )->as_string);
6543
6544         my $wrap = qq{I\'d recommend removing $chk_file. Its signature
6545 is invalid. Maybe you have configured your 'urllist' with
6546 a bad URL. Please check this array with 'o conf urllist', and
6547 retry.};
6548
6549         $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6550     }
6551 }
6552
6553 #-> sub CPAN::Distribution::CHECKSUM_check_file ;
6554
6555 # sloppy is 1 when we have an old checksums file that maybe is good
6556 # enough
6557
6558 sub CHECKSUM_check_file {
6559     my($self,$chk_file,$sloppy) = @_;
6560     my($cksum,$file,$basename);
6561
6562     $sloppy ||= 0;
6563     $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
6564     my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
6565                                                       q{check_sigs});
6566     if ($check_sigs) {
6567         if ($CPAN::META->has_inst("Module::Signature")) {
6568             $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
6569             $self->SIG_check_file($chk_file);
6570         } else {
6571             $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
6572         }
6573     }
6574
6575     $file = $self->{localfile};
6576     $basename = File::Basename::basename($file);
6577     my $fh = FileHandle->new;
6578     if (open $fh, $chk_file){
6579         local($/);
6580         my $eval = <$fh>;
6581         $eval =~ s/\015?\012/\n/g;
6582         close $fh;
6583         my($comp) = Safe->new();
6584         $cksum = $comp->reval($eval);
6585         if ($@) {
6586             rename $chk_file, "$chk_file.bad";
6587             Carp::confess($@) if $@;
6588         }
6589     } else {
6590         Carp::carp "Could not open $chk_file for reading";
6591     }
6592
6593     if (! ref $cksum or ref $cksum ne "HASH") {
6594         $CPAN::Frontend->mywarn(qq{
6595 Warning: checksum file '$chk_file' broken.
6596
6597 When trying to read that file I expected to get a hash reference
6598 for further processing, but got garbage instead.
6599 });
6600         my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
6601         $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6602         $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
6603         return;
6604     } elsif (exists $cksum->{$basename}{sha256}) {
6605         $self->debug("Found checksum for $basename:" .
6606                      "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;
6607
6608         open($fh, $file);
6609         binmode $fh;
6610         my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
6611         $fh->close;
6612         $fh = CPAN::Tarzip->TIEHANDLE($file);
6613
6614         unless ($eq) {
6615           my $dg = Digest::SHA->new(256);
6616           my($data,$ref);
6617           $ref = \$data;
6618           while ($fh->READ($ref, 4096) > 0){
6619             $dg->add($data);
6620           }
6621           my $hexdigest = $dg->hexdigest;
6622           $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
6623         }
6624
6625         if ($eq) {
6626           $CPAN::Frontend->myprint("Checksum for $file ok\n");
6627           return $self->{CHECKSUM_STATUS} = "OK";
6628         } else {
6629             $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
6630                                      qq{distribution file. }.
6631                                      qq{Please investigate.\n\n}.
6632                                      $self->as_string,
6633                                      $CPAN::META->instance(
6634                                                            'CPAN::Author',
6635                                                            $self->cpan_userid
6636                                                           )->as_string);
6637
6638             my $wrap = qq{I\'d recommend removing $file. Its
6639 checksum is incorrect. Maybe you have configured your 'urllist' with
6640 a bad URL. Please check this array with 'o conf urllist', and
6641 retry.};
6642
6643             $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
6644
6645             # former versions just returned here but this seems a
6646             # serious threat that deserves a die
6647
6648             # $CPAN::Frontend->myprint("\n\n");
6649             # sleep 3;
6650             # return;
6651         }
6652         # close $fh if fileno($fh);
6653     } else {
6654         return if $sloppy;
6655         unless ($self->{CHECKSUM_STATUS}) {
6656             $CPAN::Frontend->mywarn(qq{
6657 Warning: No checksum for $basename in $chk_file.
6658
6659 The cause for this may be that the file is very new and the checksum
6660 has not yet been calculated, but it may also be that something is
6661 going awry right now.
6662 });
6663             my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
6664             $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
6665         }
6666         $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
6667         return;
6668     }
6669 }
6670
6671 #-> sub CPAN::Distribution::eq_CHECKSUM ;
6672 sub eq_CHECKSUM {
6673     my($self,$fh,$expect) = @_;
6674     if ($CPAN::META->has_inst("Digest::SHA")) {
6675         my $dg = Digest::SHA->new(256);
6676         my($data);
6677         while (read($fh, $data, 4096)){
6678             $dg->add($data);
6679         }
6680         my $hexdigest = $dg->hexdigest;
6681         # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
6682         return $hexdigest eq $expect;
6683     }
6684     return 1;
6685 }
6686
6687 #-> sub CPAN::Distribution::force ;
6688
6689 # Both CPAN::Modules and CPAN::Distributions know if "force" is in
6690 # effect by autoinspection, not by inspecting a global variable. One
6691 # of the reason why this was chosen to work that way was the treatment
6692 # of dependencies. They should not automatically inherit the force
6693 # status. But this has the downside that ^C and die() will return to
6694 # the prompt but will not be able to reset the force_update
6695 # attributes. We try to correct for it currently in the read_metadata
6696 # routine, and immediately before we check for a Signal. I hope this
6697 # works out in one of v1.57_53ff
6698
6699 # "Force get forgets previous error conditions"
6700
6701 #-> sub CPAN::Distribution::fforce ;
6702 sub fforce {
6703   my($self, $method) = @_;
6704   $self->force($method,1);
6705 }
6706
6707 #-> sub CPAN::Distribution::force ;
6708 sub force {
6709   my($self, $method,$fforce) = @_;
6710   my %phase_map = (
6711                    get => [
6712                            "unwrapped",
6713                            "build_dir",
6714                            "archived",
6715                            "localfile",
6716                            "CHECKSUM_STATUS",
6717                            "signature_verify",
6718                            "prefs",
6719                            "prefs_file",
6720                            "prefs_file_doc",
6721                           ],
6722                    make => [
6723                             "writemakefile",
6724                             "make",
6725                             "modulebuild",
6726                             "prereq_pm",
6727                             "prereq_pm_detected",
6728                            ],
6729                    test => [
6730                             "badtestcnt",
6731                             "make_test",
6732                            ],
6733                    install => [
6734                                "install",
6735                               ],
6736                    unknown => [
6737                                "reqtype",
6738                                "yaml_content",
6739                               ],
6740                   );
6741   my $methodmatch = 0;
6742   my $ldebug = 0;
6743  PHASE: for my $phase (qw(unknown get make test install)) { # order matters
6744       $methodmatch = 1 if $fforce || $phase eq $method;
6745       next unless $methodmatch;
6746     ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
6747           if ($phase eq "get") {
6748               if (substr($self->id,-1,1) eq "."
6749                   && $att =~ /(unwrapped|build_dir|archived)/ ) {
6750                   # cannot be undone for local distros
6751                   next ATTRIBUTE;
6752               }
6753               if ($att eq "build_dir"
6754                   && $self->{build_dir}
6755                   && $CPAN::META->{is_tested}
6756                  ) {
6757                   delete $CPAN::META->{is_tested}{$self->{build_dir}};
6758               }
6759           } elsif ($phase eq "test") {
6760               if ($att eq "make_test"
6761                   && $self->{make_test}
6762                   && $self->{make_test}{COMMANDID}
6763                   && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
6764                  ) {
6765                   # endless loop too likely
6766                   next ATTRIBUTE;
6767               }
6768           }
6769           delete $self->{$att};
6770           if ($ldebug || $CPAN::DEBUG) {
6771               # local $CPAN::DEBUG = 16; # Distribution
6772               CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
6773           }
6774       }
6775   }
6776   if ($method && $method =~ /make|test|install/) {
6777     $self->{force_update} = 1; # name should probably have been force_install
6778   }
6779 }
6780
6781 #-> sub CPAN::Distribution::notest ;
6782 sub notest {
6783   my($self, $method) = @_;
6784   # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
6785   $self->{"notest"}++; # name should probably have been force_install
6786 }
6787
6788 #-> sub CPAN::Distribution::unnotest ;
6789 sub unnotest {
6790   my($self) = @_;
6791   # warn "XDEBUG: deleting notest";
6792   delete $self->{notest};
6793 }
6794
6795 #-> sub CPAN::Distribution::unforce ;
6796 sub unforce {
6797   my($self) = @_;
6798   delete $self->{force_update};
6799 }
6800
6801 #-> sub CPAN::Distribution::isa_perl ;
6802 sub isa_perl {
6803   my($self) = @_;
6804   my $file = File::Basename::basename($self->id);
6805   if ($file =~ m{ ^ perl
6806                   -?
6807                   (5)
6808                   ([._-])
6809                   (
6810                    \d{3}(_[0-4][0-9])?
6811                    |
6812                    \d+\.\d+
6813                   )
6814                   \.tar[._-](?:gz|bz2)
6815                   (?!\n)\Z
6816                 }xs){
6817     return "$1.$3";
6818   } elsif ($self->cpan_comment
6819            &&
6820            $self->cpan_comment =~ /isa_perl\(.+?\)/){
6821     return $1;
6822   }
6823 }
6824
6825
6826 #-> sub CPAN::Distribution::perl ;
6827 sub perl {
6828     my ($self) = @_;
6829     if (! $self) {
6830         use Carp qw(carp);
6831         carp __PACKAGE__ . "::perl was called without parameters.";
6832     }
6833     return CPAN::HandleConfig->safe_quote($CPAN::Perl);
6834 }
6835
6836
6837 #-> sub CPAN::Distribution::make ;
6838 sub make {
6839     my($self) = @_;
6840     if (my $goto = $self->prefs->{goto}) {
6841         return $self->goto($goto);
6842     }
6843     my $make = $self->{modulebuild} ? "Build" : "make";
6844     # Emergency brake if they said install Pippi and get newest perl
6845     if ($self->isa_perl) {
6846       if (
6847           $self->called_for ne $self->id &&
6848           ! $self->{force_update}
6849          ) {
6850         # if we die here, we break bundles
6851         $CPAN::Frontend
6852             ->mywarn(sprintf(
6853                              qq{The most recent version "%s" of the module "%s"
6854 is part of the perl-%s distribution. To install that, you need to run
6855   force install %s   --or--
6856   install %s
6857 },
6858                              $CPAN::META->instance(
6859                                                    'CPAN::Module',
6860                                                    $self->called_for
6861                                                   )->cpan_version,
6862                              $self->called_for,
6863                              $self->isa_perl,
6864                              $self->called_for,
6865                              $self->id,
6866                             ));
6867         $self->{make} = CPAN::Distrostatus->new("NO isa perl");
6868         $CPAN::Frontend->mysleep(1);
6869         return;
6870       }
6871     }
6872     $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
6873     $self->get;
6874     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
6875                            ? $ENV{PERL5LIB}
6876                            : ($ENV{PERLLIB} || "");
6877     $CPAN::META->set_perl5lib;
6878     local $ENV{MAKEFLAGS}; # protect us from outer make calls
6879
6880     if ($CPAN::Signal){
6881       delete $self->{force_update};
6882       return;
6883     }
6884
6885     my $builddir;
6886   EXCUSE: {
6887         my @e;
6888         if (!$self->{archived} || $self->{archived} eq "NO") {
6889             push @e, "Is neither a tar nor a zip archive.";
6890         }
6891
6892         if (!$self->{unwrapped}
6893             || (
6894                 UNIVERSAL::can($self->{unwrapped},"failed") ?
6895                 $self->{unwrapped}->failed :
6896                 $self->{unwrapped} =~ /^NO/
6897                )) {
6898             push @e, "Had problems unarchiving. Please build manually";
6899         }
6900
6901         unless ($self->{force_update}) {
6902             exists $self->{signature_verify} and
6903                 (
6904                  UNIVERSAL::can($self->{signature_verify},"failed") ?
6905                  $self->{signature_verify}->failed :
6906                  $self->{signature_verify} =~ /^NO/
6907                 )
6908                 and push @e, "Did not pass the signature test.";
6909         }
6910
6911         if (exists $self->{writemakefile} &&
6912             (
6913              UNIVERSAL::can($self->{writemakefile},"failed") ?
6914              $self->{writemakefile}->failed :
6915              $self->{writemakefile} =~ /^NO/
6916             )) {
6917             # XXX maybe a retry would be in order?
6918             my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
6919                 $self->{writemakefile}->text :
6920                     $self->{writemakefile};
6921             $err =~ s/^NO\s*//;
6922             $err ||= "Had some problem writing Makefile";
6923             $err .= ", won't make";
6924             push @e, $err;
6925         }
6926
6927         if (defined $self->{make}) {
6928             if ($self->{make}->failed) {
6929                 if ($self->{force_update}) {
6930                     # Trying an already failed 'make' (unless somebody else blocks)
6931                 } else {
6932                     # introduced for turning recursion detection into a distrostatus
6933                     my $error = length $self->{make}>3
6934                         ? substr($self->{make},3) : "Unknown error";
6935                     $CPAN::Frontend->mywarn("Could not make: $error\n");
6936                     $self->store_persistent_state;
6937                     return;
6938                 }
6939             } else {
6940                 push @e, "Has already been made";
6941             }
6942         }
6943
6944         if ($self->{later}) { # see also undelay
6945             if ($self->unsat_prereq) {
6946                 push @e, $self->{later};
6947             }
6948         }
6949
6950         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
6951         $builddir = $self->dir or
6952             $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");
6953         unless (chdir $builddir) {
6954             push @e, "Couldn't chdir to '$builddir': $!";
6955         }
6956         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
6957     }
6958     if ($CPAN::Signal){
6959       delete $self->{force_update};
6960       return;
6961     }
6962     $CPAN::Frontend->myprint("\n  CPAN.pm: Going to build ".$self->id."\n\n");
6963     $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;
6964
6965     if ($^O eq 'MacOS') {
6966         Mac::BuildTools::make($self);
6967         return;
6968     }
6969
6970     my %env;
6971     while (my($k,$v) = each %ENV) {
6972         next unless defined $v;
6973         $env{$k} = $v;
6974     }
6975     local %ENV = %env;
6976     my $system;
6977     if (my $commandline = $self->prefs->{pl}{commandline}) {
6978         $system = $commandline;
6979         $ENV{PERL} = $^X;
6980     } elsif ($self->{'configure'}) {
6981         $system = $self->{'configure'};
6982     } elsif ($self->{modulebuild}) {
6983         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6984         $system = "$perl Build.PL $CPAN::Config->{mbuildpl_arg}";
6985     } else {
6986         my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
6987         my $switch = "";
6988 # This needs a handler that can be turned on or off:
6989 #       $switch = "-MExtUtils::MakeMaker ".
6990 #           "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
6991 #           if $] > 5.00310;
6992         my $makepl_arg = $self->make_x_arg("pl");
6993         $system = sprintf("%s%s Makefile.PL%s",
6994                           $perl,
6995                           $switch ? " $switch" : "",
6996                           $makepl_arg ? " $makepl_arg" : "",
6997                          );
6998     }
6999     if (my $env = $self->prefs->{pl}{env}) {
7000         for my $e (keys %$env) {
7001             $ENV{$e} = $env->{$e};
7002         }
7003     }
7004     if (exists $self->{writemakefile}) {
7005     } else {
7006         local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
7007         my($ret,$pid);
7008         $@ = "";
7009         my $go_via_alarm;
7010         if ($CPAN::Config->{inactivity_timeout}) {
7011             require Config;
7012             if ($Config::Config{d_alarm}
7013                 &&
7014                 $Config::Config{d_alarm} eq "define"
7015                ) {
7016                 $go_via_alarm++
7017             } else {
7018                 $CPAN::Frontend->mywarn("Warning: you have configured the config ".
7019                                         "variable 'inactivity_timeout' to ".
7020                                         "'$CPAN::Config->{inactivity_timeout}'. But ".
7021                                         "on this machine the system call 'alarm' ".
7022                                         "isn't available. This means that we cannot ".
7023                                         "provide the feature of intercepting long ".
7024                                         "waiting code and will turn this feature off.\n"
7025                                        );
7026                 $CPAN::Config->{inactivity_timeout} = 0;
7027             }
7028         }
7029         if ($go_via_alarm) {
7030             eval {
7031                 alarm $CPAN::Config->{inactivity_timeout};
7032                 local $SIG{CHLD}; # = sub { wait };
7033                 if (defined($pid = fork)) {
7034                     if ($pid) { #parent
7035                         # wait;
7036                         waitpid $pid, 0;
7037                     } else {    #child
7038                         # note, this exec isn't necessary if
7039                         # inactivity_timeout is 0. On the Mac I'd
7040                         # suggest, we set it always to 0.
7041                         exec $system;
7042                     }
7043                 } else {
7044                     $CPAN::Frontend->myprint("Cannot fork: $!");
7045                     return;
7046                 }
7047             };
7048             alarm 0;
7049             if ($@){
7050                 kill 9, $pid;
7051                 waitpid $pid, 0;
7052                 my $err = "$@";
7053                 $CPAN::Frontend->myprint($err);
7054                 $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
7055                 $@ = "";
7056                 return;
7057             }
7058         } else {
7059             if (my $expect_model = $self->_prefs_with_expect("pl")) {
7060                 $ret = $self->_run_via_expect($system,$expect_model);
7061                 if (! defined $ret
7062                     && $self->{writemakefile}
7063                     && $self->{writemakefile}->failed) {
7064                     # timeout
7065                     return;
7066                 }
7067             } else {
7068                 $ret = system($system);
7069             }
7070             if ($ret != 0) {
7071                 $self->{writemakefile} = CPAN::Distrostatus
7072                     ->new("NO '$system' returned status $ret");
7073                 $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
7074                 $self->store_persistent_state;
7075                 return;
7076             }
7077         }
7078         if (-f "Makefile" || -f "Build") {
7079           $self->{writemakefile} = CPAN::Distrostatus->new("YES");
7080           delete $self->{make_clean}; # if cleaned before, enable next
7081         } else {
7082           $self->{writemakefile} = CPAN::Distrostatus
7083               ->new(qq{NO -- Unknown reason});
7084         }
7085     }
7086     if ($CPAN::Signal){
7087       delete $self->{force_update};
7088       return;
7089     }
7090     if (my @prereq = $self->unsat_prereq){
7091         if ($prereq[0][0] eq "perl") {
7092             my $need = "requires perl '$prereq[0][1]'";
7093             my $id = $self->pretty_id;
7094             $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
7095             $self->{make} = CPAN::Distrostatus->new("NO $need");
7096             $self->store_persistent_state;
7097             return;
7098         } else {
7099             my $follow = eval { $self->follow_prereqs(@prereq); };
7100             if (0) {
7101             } elsif ($follow){
7102                 # signal success to the queuerunner
7103                 return 1;
7104             } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
7105                 $CPAN::Frontend->mywarn($@);
7106                 return;
7107             }
7108         }
7109     }
7110     if ($CPAN::Signal){
7111       delete $self->{force_update};
7112       return;
7113     }
7114     if (my $commandline = $self->prefs->{make}{commandline}) {
7115         $system = $commandline;
7116         $ENV{PERL} = $^X;
7117     } else {
7118         if ($self->{modulebuild}) {
7119             unless (-f "Build") {
7120                 my $cwd = CPAN::anycwd();
7121                 $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
7122                                         " in cwd[$cwd]. Danger, Will Robinson!");
7123                 $CPAN::Frontend->mysleep(5);
7124             }
7125             $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
7126         } else {
7127             $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
7128         }
7129         $system =~ s/\s+$//;
7130         my $make_arg = $self->make_x_arg("make");
7131         $system = sprintf("%s%s",
7132                           $system,
7133                           $make_arg ? " $make_arg" : "",
7134                          );
7135     }
7136     if (my $env = $self->prefs->{make}{env}) { # overriding the local
7137                                                # ENV of PL, not the
7138                                                # outer ENV, but
7139                                                # unlikely to be a risk
7140         for my $e (keys %$env) {
7141             $ENV{$e} = $env->{$e};
7142         }
7143     }
7144     my $expect_model = $self->_prefs_with_expect("make");
7145     my $want_expect = 0;
7146     if ( $expect_model && @{$expect_model->{talk}} ) {
7147         my $can_expect = $CPAN::META->has_inst("Expect");
7148         if ($can_expect) {
7149             $want_expect = 1;
7150         } else {
7151             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
7152                                     "system()\n");
7153         }
7154     }
7155     my $system_ok;
7156     if ($want_expect) {
7157         $system_ok = $self->_run_via_expect($system,$expect_model) == 0;
7158     } else {
7159         $system_ok = system($system) == 0;
7160     }
7161     $self->introduce_myself;
7162     if ( $system_ok ) {
7163          $CPAN::Frontend->myprint("  $system -- OK\n");
7164          $self->{make} = CPAN::Distrostatus->new("YES");
7165     } else {
7166          $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
7167          $self->{make} = CPAN::Distrostatus->new("NO");
7168          $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
7169     }
7170     $self->store_persistent_state;
7171 }
7172
7173 # CPAN::Distribution::_run_via_expect
7174 sub _run_via_expect {
7175     my($self,$system,$expect_model) = @_;
7176     CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
7177     if ($CPAN::META->has_inst("Expect")) {
7178         my $expo = Expect->new;  # expo Expect object;
7179         $expo->spawn($system);
7180         $expect_model->{mode} ||= "deterministic";
7181         if ($expect_model->{mode} eq "deterministic") {
7182             return $self->_run_via_expect_deterministic($expo,$expect_model);
7183         } elsif ($expect_model->{mode} eq "anyorder") {
7184             return $self->_run_via_expect_anyorder($expo,$expect_model);
7185         } else {
7186             die "Panic: Illegal expect mode: $expect_model->{mode}";
7187         }
7188     } else {
7189         $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
7190         return system($system);
7191     }
7192 }
7193
7194 sub _run_via_expect_anyorder {
7195     my($self,$expo,$expect_model) = @_;
7196     my $timeout = $expect_model->{timeout} || 5;
7197     my @expectacopy = @{$expect_model->{talk}}; # we trash it!
7198     my $but = "";
7199   EXPECT: while () {
7200         my($eof,$ran_into_timeout);
7201         my @match = $expo->expect($timeout,
7202                                   [ eof => sub {
7203                                         $eof++;
7204                                     } ],
7205                                   [ timeout => sub {
7206                                         $ran_into_timeout++;
7207                                     } ],
7208                                   -re => eval"qr{.}",
7209                                  );
7210         if ($match[2]) {
7211             $but .= $match[2];
7212         }
7213         $but .= $expo->clear_accum;
7214         if ($eof) {
7215             $expo->soft_close;
7216             return $expo->exitstatus();
7217         } elsif ($ran_into_timeout) {
7218             # warn "DEBUG: they are asking a question, but[$but]";
7219             for (my $i = 0; $i <= $#expectacopy; $i+=2) {
7220                 my($next,$send) = @expectacopy[$i,$i+1];
7221                 my $regex = eval "qr{$next}";
7222                 # warn "DEBUG: will compare with regex[$regex].";
7223                 if ($but =~ /$regex/) {
7224                     # warn "DEBUG: will send send[$send]";
7225                     $expo->send($send);
7226                     splice @expectacopy, $i, 2; # never allow reusing an QA pair
7227                     next EXPECT;
7228                 }
7229             }
7230             my $why = "could not answer a question during the dialog";
7231             $CPAN::Frontend->mywarn("Failing: $why\n");
7232             $self->{writemakefile} =
7233                 CPAN::Distrostatus->new("NO $why");
7234             return;
7235         }
7236     }
7237 }
7238
7239 sub _run_via_expect_deterministic {
7240     my($self,$expo,$expect_model) = @_;
7241     my $ran_into_timeout;
7242     my $timeout = $expect_model->{timeout} || 15; # currently unsettable
7243     my $expecta = $expect_model->{talk};
7244   EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
7245         my($re,$send) = @$expecta[$i,$i+1];
7246         CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
7247         my $regex = eval "qr{$re}";
7248         $expo->expect($timeout,
7249                       [ eof => sub {
7250                             my $but = $expo->clear_accum;
7251                             $CPAN::Frontend->mywarn("EOF (maybe harmless)
7252 expected[$regex]\nbut[$but]\n\n");
7253                             last EXPECT;
7254                         } ],
7255                       [ timeout => sub {
7256                             my $but = $expo->clear_accum;
7257                             $CPAN::Frontend->mywarn("TIMEOUT
7258 expected[$regex]\nbut[$but]\n\n");
7259                             $ran_into_timeout++;
7260                         } ],
7261                       -re => $regex);
7262         if ($ran_into_timeout){
7263             # note that the caller expects 0 for success
7264             $self->{writemakefile} =
7265                 CPAN::Distrostatus->new("NO timeout during expect dialog");
7266             return;
7267         }
7268         $expo->send($send);
7269     }
7270     $expo->soft_close;
7271     return $expo->exitstatus();
7272 }
7273
7274 #-> CPAN::Distribution::_validate_distropref
7275 sub _validate_distropref {
7276     my($self,@args) = @_;
7277     if (
7278         $CPAN::META->has_inst("CPAN::Kwalify")
7279         &&
7280         $CPAN::META->has_inst("Kwalify")
7281        ) {
7282         eval {CPAN::Kwalify::_validate("distroprefs",@args);};
7283         if ($@) {
7284             $CPAN::Frontend->mywarn($@);
7285         }
7286     } else {
7287         CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
7288     }
7289 }
7290
7291 #-> CPAN::Distribution::_find_prefs
7292 sub _find_prefs {
7293     my($self) = @_;
7294     my $distroid = $self->pretty_id;
7295     #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
7296     my $prefs_dir = $CPAN::Config->{prefs_dir};
7297     eval { File::Path::mkpath($prefs_dir); };
7298     if ($@) {
7299         $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
7300     }
7301     my $yaml_module = CPAN::_yaml_module;
7302     my @extensions;
7303     if ($CPAN::META->has_inst($yaml_module)) {
7304         push @extensions, "yml";
7305     } else {
7306         my @fallbacks;
7307         if ($CPAN::META->has_inst("Data::Dumper")) {
7308             push @extensions, "dd";
7309             push @fallbacks, "Data::Dumper";
7310         }
7311         if ($CPAN::META->has_inst("Storable")) {
7312             push @extensions, "st";
7313             push @fallbacks, "Storable";
7314         }
7315         if (@fallbacks) {
7316             local $" = " and ";
7317             unless ($self->{have_complained_about_missing_yaml}++) {
7318                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back ".
7319                                         "to @fallbacks to read prefs '$prefs_dir'\n");
7320             }
7321         } else {
7322             unless ($self->{have_complained_about_missing_yaml}++) {
7323                 $CPAN::Frontend->mywarn("'$yaml_module' not installed, cannot ".
7324                                         "read prefs '$prefs_dir'\n");
7325             }
7326         }
7327     }
7328     if (@extensions) {
7329         my $dh = DirHandle->new($prefs_dir)
7330             or die Carp::croak("Couldn't open '$prefs_dir': $!");
7331       DIRENT: for (sort $dh->read) {
7332             next if $_ eq "." || $_ eq "..";
7333             my $exte = join "|", @extensions;
7334             next unless /\.($exte)$/;
7335             my $thisexte = $1;
7336             my $abs = File::Spec->catfile($prefs_dir, $_);
7337             if (-f $abs) {
7338                 #CPAN->debug(sprintf "abs[%s]", $abs) if $CPAN::DEBUG;
7339                 my @distropref;
7340                 if ($thisexte eq "yml") {
7341                     # need no eval because if we have no YAML we do not try to read *.yml
7342                     #CPAN->debug(sprintf "before yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7343                     @distropref = @{CPAN->_yaml_loadfile($abs)};
7344                     #CPAN->debug(sprintf "after yaml load abs[%s]", $abs) if $CPAN::DEBUG;
7345                 } elsif ($thisexte eq "dd") {
7346                     package CPAN::Eval;
7347                     no strict;
7348                     open FH, "<$abs" or $CPAN::Frontend->mydie("Could not open '$abs': $!");
7349                     local $/;
7350                     my $eval = <FH>;
7351                     close FH;
7352                     eval $eval;
7353                     if ($@) {
7354                         $CPAN::Frontend->mydie("Error in distroprefs file $_\: $@");
7355                     }
7356                     my $i = 1;
7357                     while (${"VAR".$i}) {
7358                         push @distropref, ${"VAR".$i};
7359                         $i++;
7360                     }
7361                 } elsif ($thisexte eq "st") {
7362                     # eval because Storable is never forward compatible
7363                     eval { @distropref = @{scalar Storable::retrieve($abs)}; };
7364                     if ($@) {
7365                         $CPAN::Frontend->mywarn("Error reading distroprefs file ".
7366                                                 "$_, skipping\: $@");
7367                         $CPAN::Frontend->mysleep(4);
7368                         next DIRENT;
7369                     }
7370                 }
7371                 # $DB::single=1;
7372                 #CPAN->debug(sprintf "#distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7373               ELEMENT: for my $y (0..$#distropref) {
7374                     my $distropref = $distropref[$y];
7375                     $self->_validate_distropref($distropref,$abs,$y);
7376                     my $match = $distropref->{match};
7377                     unless ($match) {
7378                         #CPAN->debug("no 'match' in abs[$abs], skipping") if $CPAN::DEBUG;
7379                         next ELEMENT;
7380                     }
7381                     my $ok = 1;
7382                     # do not take the order of C<keys %$match> because
7383                     # "module" is by far the slowest
7384                     my $saw_valid_subkeys = 0;
7385                     for my $sub_attribute (qw(distribution perl perlconfig module)) {
7386                         next unless exists $match->{$sub_attribute};
7387                         $saw_valid_subkeys++;
7388                         my $qr = eval "qr{$distropref->{match}{$sub_attribute}}";
7389                         if ($sub_attribute eq "module") {
7390                             my $okm = 0;
7391                             #CPAN->debug(sprintf "distropref[%d]", scalar @distropref) if $CPAN::DEBUG;
7392                             my @modules = $self->containsmods;
7393                             #CPAN->debug(sprintf "modules[%s]", join(",",@modules)) if $CPAN::DEBUG;
7394                           MODULE: for my $module (@modules) {
7395                                 $okm ||= $module =~ /$qr/;
7396                                 last MODULE if $okm;
7397                             }
7398                             $ok &&= $okm;
7399                         } elsif ($sub_attribute eq "distribution") {
7400                             my $okd = $distroid =~ /$qr/;
7401                             $ok &&= $okd;
7402                         } elsif ($sub_attribute eq "perl") {
7403                             my $okp = $^X =~ /$qr/;
7404                             $ok &&= $okp;
7405                         } elsif ($sub_attribute eq "perlconfig") {
7406                             for my $perlconfigkey (keys %{$match->{perlconfig}}) {
7407                                 my $perlconfigval = $match->{perlconfig}->{$perlconfigkey};
7408                                 # XXX should probably warn if Config does not exist
7409                                 my $okpc = $Config::Config{$perlconfigkey} =~ /$perlconfigval/;
7410                                 $ok &&= $okpc;
7411                                 last if $ok == 0;
7412                             }
7413                         } else {
7414                             $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7415                                                    "unknown sub_attribut '$sub_attribute'. ".
7416                                                    "Please ".
7417                                                    "remove, cannot continue.");
7418                         }
7419                         last if $ok == 0; # short circuit
7420                     }
7421                     unless ($saw_valid_subkeys) {
7422                         $CPAN::Frontend->mydie("Nonconforming .$thisexte file '$abs': ".
7423                                                "missing match/* subattribute. ".
7424                                                "Please ".
7425                                                "remove, cannot continue.");
7426                     }
7427                     #CPAN->debug(sprintf "ok[%d]", $ok) if $CPAN::DEBUG;
7428                     if ($ok) {
7429                         return {
7430                                 prefs => $distropref,
7431                                 prefs_file => $abs,
7432                                 prefs_file_doc => $y,
7433                                };
7434                     }
7435
7436                 }
7437             }
7438         }
7439         $dh->close;
7440     }
7441     return;
7442 }
7443
7444 # CPAN::Distribution::prefs
7445 sub prefs {
7446     my($self) = @_;
7447     if (exists $self->{negative_prefs_cache}
7448         &&
7449         $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
7450        ) {
7451         delete $self->{negative_prefs_cache};
7452         delete $self->{prefs};
7453     }
7454     if (exists $self->{prefs}) {
7455         return $self->{prefs}; # XXX comment out during debugging
7456     }
7457     if ($CPAN::Config->{prefs_dir}) {
7458         CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
7459         my $prefs = $self->_find_prefs();
7460         $prefs ||= ""; # avoid warning next line
7461         CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
7462         if ($prefs) {
7463             for my $x (qw(prefs prefs_file prefs_file_doc)) {
7464                 $self->{$x} = $prefs->{$x};
7465             }
7466             my $bs = sprintf(
7467                              "%s[%s]",
7468                              File::Basename::basename($self->{prefs_file}),
7469                              $self->{prefs_file_doc},
7470                             );
7471             my $filler1 = "_" x 22;
7472             my $filler2 = int(66 - length($bs))/2;
7473             $filler2 = 0 if $filler2 < 0;
7474             $filler2 = " " x $filler2;
7475             $CPAN::Frontend->myprint("
7476 $filler1 D i s t r o P r e f s $filler1
7477 $filler2 $bs $filler2
7478 ");
7479             $CPAN::Frontend->mysleep(1);
7480             return $self->{prefs};
7481         }
7482     }
7483     $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
7484     return $self->{prefs} = +{};
7485 }
7486
7487 # CPAN::Distribution::make_x_arg
7488 sub make_x_arg {
7489     my($self, $whixh) = @_;
7490     my $make_x_arg;
7491     my $prefs = $self->prefs;
7492     if (
7493         $prefs
7494         && exists $prefs->{$whixh}
7495         && exists $prefs->{$whixh}{args}
7496         && $prefs->{$whixh}{args}
7497        ) {
7498         $make_x_arg = join(" ",
7499                            map {CPAN::HandleConfig
7500                                  ->safe_quote($_)} @{$prefs->{$whixh}{args}},
7501                           );
7502     }
7503     my $what = sprintf "make%s_arg", $whixh eq "make" ? "" : $whixh;
7504     $make_x_arg ||= $CPAN::Config->{$what};
7505     return $make_x_arg;
7506 }
7507
7508 # CPAN::Distribution::_make_command
7509 sub _make_command {
7510     my ($self) = @_;
7511     if ($self) {
7512         return
7513             CPAN::HandleConfig
7514                 ->safe_quote(
7515                              CPAN::HandleConfig->prefs_lookup($self,
7516                                                               q{make})
7517                              || $Config::Config{make}
7518                              || 'make'
7519                             );
7520     } else {
7521         # Old style call, without object. Deprecated
7522         Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
7523         return
7524           safe_quote(undef,
7525                      CPAN::HandleConfig->prefs_lookup($self,q{make})
7526                      || $CPAN::Config->{make}
7527                      || $Config::Config{make}
7528                      || 'make');
7529     }
7530 }
7531
7532 #-> sub CPAN::Distribution::follow_prereqs ;
7533 sub follow_prereqs {
7534     my($self) = shift;
7535     my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
7536     return unless @prereq_tuples;
7537     my @prereq = map { $_->[0] } @prereq_tuples;
7538     my $pretty_id = $self->pretty_id;
7539     my %map = (
7540                b => "build_requires",
7541                r => "requires",
7542                c => "commandline",
7543               );
7544     my($filler1,$filler2,$filler3,$filler4);
7545     # $DB::single=1;
7546     my $unsat = "Unsatisfied dependencies detected during";
7547     my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
7548     {
7549         my $r = int(($w - length($unsat))/2);
7550         my $l = $w - length($unsat) - $r;
7551         $filler1 = "-"x4 . " "x$l;
7552         $filler2 = " "x$r . "-"x4 . "\n";
7553     }
7554     {
7555         my $r = int(($w - length($pretty_id))/2);
7556         my $l = $w - length($pretty_id) - $r;
7557         $filler3 = "-"x4 . " "x$l;
7558         $filler4 = " "x$r . "-"x4 . "\n";
7559     }
7560     $CPAN::Frontend->
7561         myprint("$filler1 $unsat $filler2".
7562                 "$filler3 $pretty_id $filler4".
7563                 join("", map {"    $_->[0] \[$map{$_->[1]}]\n"} @prereq_tuples),
7564                );
7565     my $follow = 0;
7566     if ($CPAN::Config->{prerequisites_policy} eq "follow") {
7567         $follow = 1;
7568     } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
7569         my $answer = CPAN::Shell::colorable_makemaker_prompt(
7570 "Shall I follow them and prepend them to the queue
7571 of modules we are processing right now?", "yes");
7572         $follow = $answer =~ /^\s*y/i;
7573     } else {
7574         local($") = ", ";
7575         $CPAN::Frontend->
7576             myprint("  Ignoring dependencies on modules @prereq\n");
7577     }
7578     if ($follow) {
7579         my $id = $self->id;
7580         # color them as dirty
7581         for my $p (@prereq) {
7582             # warn "calling color_cmd_tmps(0,1)";
7583             my $any = CPAN::Shell->expandany($p);
7584             if ($any) {
7585                 $any->color_cmd_tmps(0,2);
7586             } else {
7587                 $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$p'\n");
7588                 $CPAN::Frontend->mysleep(2);
7589             }
7590         }
7591         # queue them and re-queue yourself
7592         CPAN::Queue->jumpqueue([$id,$self->{reqtype}],
7593                                reverse @prereq_tuples);
7594         $self->{later} = "Delayed until after prerequisites";
7595         return 1; # signal success to the queuerunner
7596     }
7597 }
7598
7599 #-> sub CPAN::Distribution::unsat_prereq ;
7600 # return ([Foo=>1],[Bar=>1.2]) for normal modules
7601 # return ([perl=>5.008]) if we need a newer perl than we are running under
7602 sub unsat_prereq {
7603     my($self) = @_;
7604     my $prereq_pm = $self->prereq_pm or return;
7605     my(@need);
7606     my %merged = (%{$prereq_pm->{requires}||{}},%{$prereq_pm->{build_requires}||{}});
7607     my @merged = %merged;
7608     CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
7609   NEED: while (my($need_module, $need_version) = each %merged) {
7610         my($available_version,$available_file,$nmo);
7611         if ($need_module eq "perl") {
7612             $available_version = $];
7613             $available_file = $^X;
7614         } else {
7615             $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
7616             next if $nmo->uptodate;
7617             $available_file = $nmo->available_file;
7618
7619             # if they have not specified a version, we accept any installed one
7620             if (defined $available_file
7621                 and ( # a few quick shortcurcuits
7622                      not defined $need_version
7623                      or $need_version eq '0'    # "==" would trigger warning when not numeric
7624                      or $need_version eq "undef"
7625                     )) {
7626                 next NEED;
7627             }
7628
7629             $available_version = $nmo->available_version;
7630         }
7631
7632         # We only want to install prereqs if either they're not installed
7633         # or if the installed version is too old. We cannot omit this
7634         # check, because if 'force' is in effect, nobody else will check.
7635         if (defined $available_file) {
7636             my(@all_requirements) = split /\s*,\s*/, $need_version;
7637             local($^W) = 0;
7638             my $ok = 0;
7639           RQ: for my $rq (@all_requirements) {
7640                 if ($rq =~ s|>=\s*||) {
7641                 } elsif ($rq =~ s|>\s*||) {
7642                     # 2005-12: one user
7643                     if (CPAN::Version->vgt($available_version,$rq)){
7644                         $ok++;
7645                     }
7646                     next RQ;
7647                 } elsif ($rq =~ s|!=\s*||) {
7648                     # 2005-12: no user
7649                     if (CPAN::Version->vcmp($available_version,$rq)){
7650                         $ok++;
7651                         next RQ;
7652                     } else {
7653                         last RQ;
7654                     }
7655                 } elsif ($rq =~ m|<=?\s*|) {
7656                     # 2005-12: no user
7657                     $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
7658                     $ok++;
7659                     next RQ;
7660                 }
7661                 if (! CPAN::Version->vgt($rq, $available_version)){
7662                     $ok++;
7663                 }
7664                 CPAN->debug(sprintf("need_module[%s]available_file[%s]".
7665                                     "available_version[%s]rq[%s]ok[%d]",
7666                                     $need_module,
7667                                     $available_file,
7668                                     $available_version,
7669                                     CPAN::Version->readable($rq),
7670                                     $ok,
7671                                    )) if $CPAN::DEBUG;
7672             }
7673             next NEED if $ok == @all_requirements;
7674         }
7675
7676         if ($need_module eq "perl") {
7677             return ["perl", $need_version];
7678         }
7679         if ($self->{sponsored_mods}{$need_module}++){
7680             # We have already sponsored it and for some reason it's still
7681             # not available. So we do ... what??
7682
7683             # if we push it again, we have a potential infinite loop
7684
7685             # The following "next" was a very problematic construct.
7686             # It helped a lot but broke some day and had to be
7687             # replaced.
7688
7689             # We must be able to deal with modules that come again and
7690             # again as a prereq and have themselves prereqs and the
7691             # queue becomes long but finally we would find the correct
7692             # order. The RecursiveDependency check should trigger a
7693             # die when it's becoming too weird. Unfortunately removing
7694             # this next breaks many other things.
7695
7696             # The bug that brought this up is described in Todo under
7697             # "5.8.9 cannot install Compress::Zlib"
7698
7699             # next; # this is the next that had to go away
7700
7701             # The following "next NEED" are fine and the error message
7702             # explains well what is going on. For example when the DBI
7703             # fails and consequently DBD::SQLite fails and now we are
7704             # processing CPAN::SQLite. Then we must have a "next" for
7705             # DBD::SQLite. How can we get it and how can we identify
7706             # all other cases we must identify?
7707
7708             my $do = $nmo->distribution;
7709             next NEED unless $do; # not on CPAN
7710           NOSAYER: for my $nosayer (
7711                                     "unwrapped",
7712                                     "writemakefile",
7713                                     "signature_verify",
7714                                     "make",
7715                                     "make_test",
7716                                     "install",
7717                                     "make_clean",
7718                                    ) {
7719                 if ($do->{$nosayer}) {
7720                     if (UNIVERSAL::can($do->{$nosayer},"failed") ?
7721                         $do->{$nosayer}->failed :
7722                         $do->{$nosayer} =~ /^NO/) {
7723                         if ($nosayer eq "make_test"
7724                             &&
7725                             $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
7726                            ) {
7727                             next NOSAYER;
7728                         }
7729                         $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7730                                                 "'$need_module => $need_version' ".
7731                                                 "for '$self->{ID}' failed when ".
7732                                                 "processing '$do->{ID}' with ".
7733                                                 "'$nosayer => $do->{$nosayer}'. Continuing, ".
7734                                                 "but chances to succeed are limited.\n"
7735                                                );
7736                         next NEED;
7737                     } else { # the other guy succeeded
7738                         if ($nosayer eq "install") {
7739                             # we had this with
7740                             # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
7741                             # 2007-03
7742                             $CPAN::Frontend->mywarn("Warning: Prerequisite ".
7743                                                     "'$need_module => $need_version' ".
7744                                                     "for '$self->{ID}' already installed ".
7745                                                     "but installation looks suspicious. ".
7746                                                     "Skipping another installation attempt, ".
7747                                                     "to prevent looping endlessly.\n"
7748                                                    );
7749                             next NEED;
7750                         }
7751                     }
7752                 }
7753             }
7754         }
7755         my $needed_as = exists $prereq_pm->{requires}{$need_module} ? "r" : "b";
7756         push @need, [$need_module,$needed_as];
7757     }
7758     my @unfolded = map { "[".join(",",@$_)."]" } @need;
7759     CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
7760     @need;
7761 }
7762
7763 #-> sub CPAN::Distribution::read_yaml ;
7764 sub read_yaml {
7765     my($self) = @_;
7766     return $self->{yaml_content} if exists $self->{yaml_content};
7767     my $build_dir = $self->{build_dir};
7768     my $yaml = File::Spec->catfile($build_dir,"META.yml");
7769     $self->debug("yaml[$yaml]") if $CPAN::DEBUG;
7770     return unless -f $yaml;
7771     eval { $self->{yaml_content} = CPAN->_yaml_loadfile($yaml)->[0]; };
7772     if ($@) {
7773         $CPAN::Frontend->mywarn("Could not read ".
7774                                 "'$yaml'. Falling back to other ".
7775                                 "methods to determine prerequisites\n");
7776         return $self->{yaml_content} = undef; # if we die, then we
7777                                               # cannot read YAML's own
7778                                               # META.yml
7779     }
7780     # not "authoritative"
7781     if (not exists $self->{yaml_content}{dynamic_config}
7782         or $self->{yaml_content}{dynamic_config}
7783        ) {
7784         $self->{yaml_content} = undef;
7785     }
7786     $self->debug(sprintf "yaml_content[%s]", $self->{yaml_content} || "UNDEF")
7787         if $CPAN::DEBUG;
7788     return $self->{yaml_content};
7789 }
7790
7791 #-> sub CPAN::Distribution::prereq_pm ;
7792 sub prereq_pm {
7793     my($self) = @_;
7794     $self->{prereq_pm_detected} ||= 0;
7795     CPAN->debug("ID[$self->{ID}]prereq_pm_detected[$self->{prereq_pm_detected}]") if $CPAN::DEBUG;
7796     return $self->{prereq_pm} if $self->{prereq_pm_detected};
7797     return unless $self->{writemakefile}  # no need to have succeeded
7798                                           # but we must have run it
7799         || $self->{modulebuild};
7800     CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
7801                 $self->{writemakefile}||"",
7802                 $self->{modulebuild}||"",
7803                ) if $CPAN::DEBUG;
7804     my($req,$breq);
7805     if (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
7806         $req =  $yaml->{requires} || {};
7807         $breq =  $yaml->{build_requires} || {};
7808         undef $req unless ref $req eq "HASH" && %$req;
7809         if ($req) {
7810             if ($yaml->{generated_by} &&
7811                 $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
7812                 my $eummv = do { local $^W = 0; $1+0; };
7813                 if ($eummv < 6.2501) {
7814                     # thanks to Slaven for digging that out: MM before
7815                     # that could be wrong because it could reflect a
7816                     # previous release
7817                     undef $req;
7818                 }
7819             }
7820             my $areq;
7821             my $do_replace;
7822             while (my($k,$v) = each %{$req||{}}) {
7823                 if ($v =~ /\d/) {
7824                     $areq->{$k} = $v;
7825                 } elsif ($k =~ /[A-Za-z]/ &&
7826                          $v =~ /[A-Za-z]/ &&
7827                          $CPAN::META->exists("Module",$v)
7828                         ) {
7829                     $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
7830                                             "requires hash: $k => $v; I'll take both ".
7831                                             "key and value as a module name\n");
7832                     $CPAN::Frontend->mysleep(1);
7833                     $areq->{$k} = 0;
7834                     $areq->{$v} = 0;
7835                     $do_replace++;
7836                 }
7837             }
7838             $req = $areq if $do_replace;
7839         }
7840     }
7841     unless ($req || $breq) {
7842         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7843         my $makefile = File::Spec->catfile($build_dir,"Makefile");
7844         my $fh;
7845         if (-f $makefile
7846             and
7847             $fh = FileHandle->new("<$makefile\0")) {
7848             CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
7849             local($/) = "\n";
7850             while (<$fh>) {
7851                 last if /MakeMaker post_initialize section/;
7852                 my($p) = m{^[\#]
7853                            \s+PREREQ_PM\s+=>\s+(.+)
7854                        }x;
7855                 next unless $p;
7856                 # warn "Found prereq expr[$p]";
7857
7858                 #  Regexp modified by A.Speer to remember actual version of file
7859                 #  PREREQ_PM hash key wants, then add to
7860                 while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ){
7861                     # In case a prereq is mentioned twice, complain.
7862                     if ( defined $req->{$1} ) {
7863                         warn "Warning: PREREQ_PM mentions $1 more than once, ".
7864                             "last mention wins";
7865                     }
7866                     my($m,$n) = ($1,$2);
7867                     if ($n =~ /^q\[(.*?)\]$/) {
7868                         $n = $1;
7869                     }
7870                     $req->{$m} = $n;
7871                 }
7872                 last;
7873             }
7874         }
7875     }
7876     unless ($req || $breq) {
7877         my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
7878         my $buildfile = File::Spec->catfile($build_dir,"Build");
7879         if (-f $buildfile) {
7880             CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
7881             my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
7882             if (-f $build_prereqs) {
7883                 CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
7884                 my $content = do { local *FH;
7885                                    open FH, $build_prereqs
7886                                        or $CPAN::Frontend->mydie("Could not open ".
7887                                                                  "'$build_prereqs': $!");
7888                                    local $/;
7889                                    <FH>;
7890                                };
7891                 my $bphash = eval $content;
7892                 if ($@) {
7893                 } else {
7894                     $req  = $bphash->{requires} || +{};
7895                     $breq = $bphash->{build_requires} || +{};
7896                 }
7897             }
7898         }
7899     }
7900     if (-f "Build.PL"
7901         && ! -f "Makefile.PL"
7902         && ! exists $req->{"Module::Build"}
7903         && ! $CPAN::META->has_inst("Module::Build")) {
7904         $CPAN::Frontend->mywarn("  Warning: CPAN.pm discovered Module::Build as ".
7905                                 "undeclared prerequisite.\n".
7906                                 "  Adding it now as such.\n"
7907                                );
7908         $CPAN::Frontend->mysleep(5);
7909         $req->{"Module::Build"} = 0;
7910         delete $self->{writemakefile};
7911     }
7912     if ($req || $breq) {
7913         $self->{prereq_pm_detected}++;
7914         return $self->{prereq_pm} = { requires => $req, build_requires => $breq };
7915     }
7916 }
7917
7918 #-> sub CPAN::Distribution::test ;
7919 sub test {
7920     my($self) = @_;
7921     if (my $goto = $self->prefs->{goto}) {
7922         return $self->goto($goto);
7923     }
7924     $self->make;
7925     if ($CPAN::Signal){
7926       delete $self->{force_update};
7927       return;
7928     }
7929     # warn "XDEBUG: checking for notest: $self->{notest} $self";
7930     if ($self->{notest}) {
7931         $CPAN::Frontend->myprint("Skipping test because of notest pragma\n");
7932         return 1;
7933     }
7934
7935     my $make = $self->{modulebuild} ? "Build" : "make";
7936
7937     local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
7938                            ? $ENV{PERL5LIB}
7939                            : ($ENV{PERLLIB} || "");
7940
7941     $CPAN::META->set_perl5lib;
7942     local $ENV{MAKEFLAGS}; # protect us from outer make calls
7943
7944     $CPAN::Frontend->myprint("Running $make test\n");
7945
7946 #    if (my @prereq = $self->unsat_prereq){
7947 #        if ( $CPAN::DEBUG ) {
7948 #            require Data::Dumper;
7949 #            CPAN->debug(sprintf "unsat_prereq[%s]", Data::Dumper::Dumper(\@prereq));
7950 #        }
7951 #        unless ($prereq[0][0] eq "perl") {
7952 #            return 1 if $self->follow_prereqs(@prereq); # signal success to the queuerunner
7953 #        }
7954 #    }
7955
7956   EXCUSE: {
7957         my @e;
7958         if ($self->{make} or $self->{later}) {
7959             # go ahead
7960         } else {
7961             push @e,
7962                 "Make had some problems, won't test";
7963         }
7964
7965         exists $self->{make} and
7966             (
7967              UNIVERSAL::can($self->{make},"failed") ?
7968              $self->{make}->failed :
7969              $self->{make} =~ /^NO/
7970             ) and push @e, "Can't test without successful make";
7971         $self->{badtestcnt} ||= 0;
7972         if ($self->{badtestcnt} > 0) {
7973             require Data::Dumper;
7974             CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
7975             push @e, "Won't repeat unsuccessful test during this command";
7976         }
7977
7978         push @e, $self->{later} if $self->{later};
7979
7980         if (exists $self->{build_dir}) {
7981             if (exists $self->{make_test}) {
7982                 if (
7983                     UNIVERSAL::can($self->{make_test},"failed") ?
7984                     $self->{make_test}->failed :
7985                     $self->{make_test} =~ /^NO/
7986                    ) {
7987                     if (
7988                         UNIVERSAL::can($self->{make_test},"commandid")
7989                         &&
7990                         $self->{make_test}->commandid == $CPAN::CurrentCommandId
7991                        ) {
7992                         push @e, "Has already been tested within this command";
7993                     }
7994                 } else {
7995                     push @e, "Has already been tested successfully";
7996                 }
7997             }
7998         } elsif (!@e) {
7999             push @e, "Has no own directory";
8000         }
8001         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8002         unless (chdir $self->{build_dir}) {
8003             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8004         }
8005         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8006     }
8007     $self->debug("Changed directory to $self->{build_dir}")
8008         if $CPAN::DEBUG;
8009
8010     if ($^O eq 'MacOS') {
8011         Mac::BuildTools::make_test($self);
8012         return;
8013     }
8014
8015     if ($self->{modulebuild}) {
8016         my $v = CPAN::Shell->expand("Module","Test::Harness")->inst_version;
8017         if (CPAN::Version->vlt($v,2.62)) {
8018             $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
8019   '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
8020             $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
8021             return;
8022         }
8023     }
8024
8025     my $system;
8026     if (my $commandline = $self->prefs->{test}{commandline}) {
8027         $system = $commandline;
8028         $ENV{PERL} = $^X;
8029     } elsif ($self->{modulebuild}) {
8030         $system = sprintf "%s test", $self->_build_command();
8031     } else {
8032         $system = join " ", $self->_make_command(), "test";
8033     }
8034     my $make_test_arg = $self->make_x_arg("test");
8035     $system = sprintf("%s%s",
8036                       $system,
8037                       $make_test_arg ? " $make_test_arg" : "",
8038                      );
8039     my($tests_ok);
8040     my %env;
8041     while (my($k,$v) = each %ENV) {
8042         next unless defined $v;
8043         $env{$k} = $v;
8044     }
8045     local %ENV = %env;
8046     if (my $env = $self->prefs->{test}{env}) {
8047         for my $e (keys %$env) {
8048             $ENV{$e} = $env->{$e};
8049         }
8050     }
8051     my $expect_model = $self->_prefs_with_expect("test");
8052     my $want_expect = 0;
8053     if ( $expect_model && @{$expect_model->{talk}} ) {
8054         my $can_expect = $CPAN::META->has_inst("Expect");
8055         if ($can_expect) {
8056             $want_expect = 1;
8057         } else {
8058             $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
8059                                     "testing without\n");
8060         }
8061     }
8062     my $test_report = CPAN::HandleConfig->prefs_lookup($self,
8063                                                        q{test_report});
8064     my $want_report;
8065     if ($test_report) {
8066         my $can_report = $CPAN::META->has_inst("CPAN::Reporter");
8067         if ($can_report) {
8068             $want_report = 1;
8069         } else {
8070             $CPAN::Frontend->mywarn("CPAN::Reporter not installed, falling back to ".
8071                                     "testing without\n");
8072         }
8073     }
8074     my $ready_to_report = $want_report;
8075     if ($ready_to_report
8076         && (
8077             substr($self->id,-1,1) eq "."
8078             ||
8079             $self->author->id eq "LOCAL"
8080            )
8081        ) {
8082         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8083                                 "for local directories\n");
8084         $ready_to_report = 0;
8085     }
8086     if ($ready_to_report
8087         &&
8088         $self->prefs->{patches}
8089         &&
8090         @{$self->prefs->{patches}}
8091         &&
8092         $self->{patched}
8093        ) {
8094         $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
8095                                 "when the source has been patched\n");
8096         $ready_to_report = 0;
8097     }
8098     if ($want_expect) {
8099         if ($ready_to_report) {
8100             $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
8101                                     "not supported when distroprefs specify ".
8102                                     "an interactive test\n");
8103         }
8104         $tests_ok = $self->_run_via_expect($system,$expect_model) == 0;
8105     } elsif ( $ready_to_report ) {
8106         $tests_ok = CPAN::Reporter::test($self, $system);
8107     } else {
8108         $tests_ok = system($system) == 0;
8109     }
8110     $self->introduce_myself;
8111     if ( $tests_ok ) {
8112         {
8113             my @prereq;
8114
8115             # local $CPAN::DEBUG = 16; # Distribution
8116             for my $m (keys %{$self->{sponsored_mods}}) {
8117                 my $m_obj = CPAN::Shell->expand("Module",$m) or next;
8118                 # XXX we need available_version which reflects
8119                 # $ENV{PERL5LIB} so that already tested but not yet
8120                 # installed modules are counted.
8121                 my $available_version = $m_obj->available_version;
8122                 my $available_file = $m_obj->available_file;
8123                 if ($available_version &&
8124                     !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
8125                    ) {
8126                     CPAN->debug("m[$m] good enough available_version[$available_version]")
8127                         if $CPAN::DEBUG;
8128                 } elsif ($available_file
8129                          && (
8130                              !$self->{prereq_pm}{$m}
8131                              ||
8132                              $self->{prereq_pm}{$m} == 0
8133                             )
8134                         ) {
8135                     # lex Class::Accessor::Chained::Fast which has no $VERSION
8136                     CPAN->debug("m[$m] have available_file[$available_file]")
8137                         if $CPAN::DEBUG;
8138                 } else {
8139                     push @prereq, $m;
8140                 }
8141             }
8142             if (@prereq){
8143                 my $cnt = @prereq;
8144                 my $which = join ",", @prereq;
8145                 my $but = $cnt == 1 ? "one dependency not OK ($which)" :
8146                     "$cnt dependencies missing ($which)";
8147                 $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
8148                 $self->{make_test} = CPAN::Distrostatus->new("NO $but");
8149                 $self->store_persistent_state;
8150                 return;
8151             }
8152         }
8153
8154         $CPAN::Frontend->myprint("  $system -- OK\n");
8155         $self->{make_test} = CPAN::Distrostatus->new("YES");
8156         $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
8157         # probably impossible to need the next line because badtestcnt
8158         # has a lifespan of one command
8159         delete $self->{badtestcnt};
8160     } else {
8161         $self->{make_test} = CPAN::Distrostatus->new("NO");
8162         $self->{badtestcnt}++;
8163         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8164     }
8165     $self->store_persistent_state;
8166 }
8167
8168 sub _prefs_with_expect {
8169     my($self,$where) = @_;
8170     return unless my $prefs = $self->prefs;
8171     return unless my $where_prefs = $prefs->{$where};
8172     if ($where_prefs->{expect}) {
8173         return {
8174                 mode => "deterministic",
8175                 timeout => 15,
8176                 talk => $where_prefs->{expect},
8177                };
8178     } elsif ($where_prefs->{"eexpect"}) {
8179         return $where_prefs->{"eexpect"};
8180     }
8181     return;
8182 }
8183
8184 #-> sub CPAN::Distribution::clean ;
8185 sub clean {
8186     my($self) = @_;
8187     my $make = $self->{modulebuild} ? "Build" : "make";
8188     $CPAN::Frontend->myprint("Running $make clean\n");
8189     unless (exists $self->{archived}) {
8190         $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
8191                                 "/untarred, nothing done\n");
8192         return 1;
8193     }
8194     unless (exists $self->{build_dir}) {
8195         $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
8196         return 1;
8197     }
8198     if (exists $self->{writemakefile}
8199         and $self->{writemakefile}->failed
8200        ) {
8201         $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
8202         return 1;
8203     }
8204   EXCUSE: {
8205         my @e;
8206         exists $self->{make_clean} and $self->{make_clean} eq "YES" and
8207             push @e, "make clean already called once";
8208         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8209     }
8210     chdir $self->{build_dir} or
8211         Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
8212     $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;
8213
8214     if ($^O eq 'MacOS') {
8215         Mac::BuildTools::make_clean($self);
8216         return;
8217     }
8218
8219     my $system;
8220     if ($self->{modulebuild}) {
8221         unless (-f "Build") {
8222             my $cwd = CPAN::anycwd();
8223             $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
8224                                     " in cwd[$cwd]. Danger, Will Robinson!");
8225             $CPAN::Frontend->mysleep(5);
8226         }
8227         $system = sprintf "%s clean", $self->_build_command();
8228     } else {
8229         $system  = join " ", $self->_make_command(), "clean";
8230     }
8231     my $system_ok = system($system) == 0;
8232     $self->introduce_myself;
8233     if ( $system_ok ) {
8234       $CPAN::Frontend->myprint("  $system -- OK\n");
8235
8236       # $self->force;
8237
8238       # Jost Krieger pointed out that this "force" was wrong because
8239       # it has the effect that the next "install" on this distribution
8240       # will untar everything again. Instead we should bring the
8241       # object's state back to where it is after untarring.
8242
8243       for my $k (qw(
8244                     force_update
8245                     install
8246                     writemakefile
8247                     make
8248                     make_test
8249                    )) {
8250           delete $self->{$k};
8251       }
8252       $self->{make_clean} = CPAN::Distrostatus->new("YES");
8253
8254     } else {
8255       # Hmmm, what to do if make clean failed?
8256
8257       $self->{make_clean} = CPAN::Distrostatus->new("NO");
8258       $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});
8259
8260       # 2006-02-27: seems silly to me to force a make now
8261       # $self->force("make"); # so that this directory won't be used again
8262
8263     }
8264     $self->store_persistent_state;
8265 }
8266
8267 #-> sub CPAN::Distribution::goto ;
8268 sub goto {
8269     my($self,$goto) = @_;
8270     $goto = $self->normalize($goto);
8271
8272     # inject into the queue
8273
8274     CPAN::Queue->delete($self->id);
8275     CPAN::Queue->jumpqueue([$goto,$self->{reqtype}]);
8276
8277     # and run where we left off
8278
8279     my($method) = (caller(1))[3];
8280     CPAN->instance("CPAN::Distribution",$goto)->$method;
8281     CPAN::Queue->delete_first($goto);
8282 }
8283
8284 #-> sub CPAN::Distribution::install ;
8285 sub install {
8286     my($self) = @_;
8287     if (my $goto = $self->prefs->{goto}) {
8288         return $self->goto($goto);
8289     }
8290     # $DB::single=1;
8291     unless ($self->{badtestcnt}) {
8292         $self->test;
8293     }
8294     if ($CPAN::Signal){
8295       delete $self->{force_update};
8296       return;
8297     }
8298     my $make = $self->{modulebuild} ? "Build" : "make";
8299     $CPAN::Frontend->myprint("Running $make install\n");
8300   EXCUSE: {
8301         my @e;
8302         if ($self->{make} or $self->{later}) {
8303             # go ahead
8304         } else {
8305             push @e,
8306                 "Make had some problems, won't install";
8307         }
8308
8309         exists $self->{make} and
8310             (
8311              UNIVERSAL::can($self->{make},"failed") ?
8312              $self->{make}->failed :
8313              $self->{make} =~ /^NO/
8314             ) and
8315                 push @e, "Make had returned bad status, install seems impossible";
8316
8317         if (exists $self->{build_dir}) {
8318         } elsif (!@e) {
8319             push @e, "Has no own directory";
8320         }
8321
8322         if (exists $self->{make_test} and
8323             (
8324              UNIVERSAL::can($self->{make_test},"failed") ?
8325              $self->{make_test}->failed :
8326              $self->{make_test} =~ /^NO/
8327             )){
8328             if ($self->{force_update}) {
8329                 $self->{make_test}->text("FAILED but failure ignored because ".
8330                                          "'force' in effect");
8331             } else {
8332                 push @e, "make test had returned bad status, ".
8333                     "won't install without force"
8334             }
8335         }
8336         if (exists $self->{install}) {
8337             if (UNIVERSAL::can($self->{install},"text") ?
8338                 $self->{install}->text eq "YES" :
8339                 $self->{install} =~ /^YES/
8340                ) {
8341                 $CPAN::Frontend->myprint("  Already done\n");
8342                 $CPAN::META->is_installed($self->{build_dir});
8343                 return 1;
8344             } else {
8345                 # comment in Todo on 2006-02-11; maybe retry?
8346                 push @e, "Already tried without success";
8347             }
8348         }
8349
8350         push @e, $self->{later} if $self->{later};
8351
8352         $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
8353         unless (chdir $self->{build_dir}) {
8354             push @e, "Couldn't chdir to '$self->{build_dir}': $!";
8355         }
8356         $CPAN::Frontend->mywarn(join "", map {"  $_\n"} @e) and return if @e;
8357     }
8358     $self->debug("Changed directory to $self->{build_dir}")
8359         if $CPAN::DEBUG;
8360
8361     if ($^O eq 'MacOS') {
8362         Mac::BuildTools::make_install($self);
8363         return;
8364     }
8365
8366     my $system;
8367     if (my $commandline = $self->prefs->{install}{commandline}) {
8368         $system = $commandline;
8369         $ENV{PERL} = $^X;
8370     } elsif ($self->{modulebuild}) {
8371         my($mbuild_install_build_command) =
8372             exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
8373                 $CPAN::Config->{mbuild_install_build_command} ?
8374                     $CPAN::Config->{mbuild_install_build_command} :
8375                         $self->_build_command();
8376         $system = sprintf("%s install %s",
8377                           $mbuild_install_build_command,
8378                           $CPAN::Config->{mbuild_install_arg},
8379                          );
8380     } else {
8381         my($make_install_make_command) =
8382             CPAN::HandleConfig->prefs_lookup($self,
8383                                              q{make_install_make_command})
8384                   || $self->_make_command();
8385         $system = sprintf("%s install %s",
8386                           $make_install_make_command,
8387                           $CPAN::Config->{make_install_arg},
8388                          );
8389     }
8390
8391     my($stderr) = $^O eq "MSWin32" ? "" : " 2>&1 ";
8392     my $brip = CPAN::HandleConfig->prefs_lookup($self,
8393                                                 q{build_requires_install_policy});
8394     $brip ||="ask/yes";
8395     my $id = $self->id;
8396     my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
8397     my $want_install = "yes";
8398     if ($reqtype eq "b") {
8399         if ($brip eq "no") {
8400             $want_install = "no";
8401         } elsif ($brip =~ m|^ask/(.+)|) {
8402             my $default = $1;
8403             $default = "yes" unless $default =~ /^(y|n)/i;
8404             $want_install =
8405                 CPAN::Shell::colorable_makemaker_prompt
8406                       ("$id is just needed temporarily during building or testing. ".
8407                        "Do you want to install it permanently? (Y/n)",
8408                        $default);
8409         }
8410     }
8411     unless ($want_install =~ /^y/i) {
8412         my $is_only = "is only 'build_requires'";
8413         $CPAN::Frontend->mywarn("Not installing because $is_only\n");
8414         $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
8415         delete $self->{force_update};
8416         return;
8417     }
8418     my($pipe) = FileHandle->new("$system $stderr |");
8419     my($makeout) = "";
8420     while (<$pipe>){
8421         print $_; # intentionally NOT use Frontend->myprint because it
8422                   # looks irritating when we markup in color what we
8423                   # just pass through from an external program
8424         $makeout .= $_;
8425     }
8426     $pipe->close;
8427     my $close_ok = $? == 0;
8428     $self->introduce_myself;
8429     if ( $close_ok ) {
8430         $CPAN::Frontend->myprint("  $system -- OK\n");
8431         $CPAN::META->is_installed($self->{build_dir});
8432         $self->{install} = CPAN::Distrostatus->new("YES");
8433     } else {
8434         $self->{install} = CPAN::Distrostatus->new("NO");
8435         $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
8436         my $mimc =
8437             CPAN::HandleConfig->prefs_lookup($self,
8438                                              q{make_install_make_command});
8439         if (
8440             $makeout =~ /permission/s
8441             && $> > 0
8442             && (
8443                 ! $mimc
8444                 || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
8445                                                               q{make}))
8446                )
8447            ) {
8448             $CPAN::Frontend->myprint(
8449                                      qq{----\n}.
8450                                      qq{  You may have to su }.
8451                                      qq{to root to install the package\n}.
8452                                      qq{  (Or you may want to run something like\n}.
8453                                      qq{    o conf make_install_make_command 'sudo make'\n}.
8454                                      qq{  to raise your permissions.}
8455                                     );
8456         }
8457     }
8458     delete $self->{force_update};
8459     # $DB::single = 1;
8460     $self->store_persistent_state;
8461 }
8462
8463 sub introduce_myself {
8464     my($self) = @_;
8465     $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
8466 }
8467
8468 #-> sub CPAN::Distribution::dir ;
8469 sub dir {
8470     shift->{build_dir};
8471 }
8472
8473 #-> sub CPAN::Distribution::perldoc ;
8474 sub perldoc {
8475     my($self) = @_;
8476
8477     my($dist) = $self->id;
8478     my $package = $self->called_for;
8479
8480     $self->_display_url( $CPAN::Defaultdocs . $package );
8481 }
8482
8483 #-> sub CPAN::Distribution::_check_binary ;
8484 sub _check_binary {
8485     my ($dist,$shell,$binary) = @_;
8486     my ($pid,$out);
8487
8488     $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
8489       if $CPAN::DEBUG;
8490
8491     if ($CPAN::META->has_inst("File::Which")) {
8492         return File::Which::which($binary);
8493     } else {
8494         local *README;
8495         $pid = open README, "which $binary|"
8496             or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
8497         return unless $pid;
8498         while (<README>) {
8499             $out .= $_;
8500         }
8501         close README
8502             or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
8503                 and return;
8504     }
8505
8506     $CPAN::Frontend->myprint(qq{   + $out \n})
8507       if $CPAN::DEBUG && $out;
8508
8509     return $out;
8510 }
8511
8512 #-> sub CPAN::Distribution::_display_url ;
8513 sub _display_url {
8514     my($self,$url) = @_;
8515     my($res,$saved_file,$pid,$out);
8516
8517     $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
8518       if $CPAN::DEBUG;
8519
8520     # should we define it in the config instead?
8521     my $html_converter = "html2text";
8522
8523     my $web_browser = $CPAN::Config->{'lynx'} || undef;
8524     my $web_browser_out = $web_browser
8525       ? CPAN::Distribution->_check_binary($self,$web_browser)
8526         : undef;
8527
8528     if ($web_browser_out) {
8529         # web browser found, run the action
8530         my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
8531         $CPAN::Frontend->myprint(qq{system[$browser $url]})
8532           if $CPAN::DEBUG;
8533         $CPAN::Frontend->myprint(qq{
8534 Displaying URL
8535   $url
8536 with browser $browser
8537 });
8538         $CPAN::Frontend->mysleep(1);
8539         system("$browser $url");
8540         if ($saved_file) { 1 while unlink($saved_file) }
8541     } else {
8542         # web browser not found, let's try text only
8543         my $html_converter_out =
8544           CPAN::Distribution->_check_binary($self,$html_converter);
8545         $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);
8546
8547         if ($html_converter_out ) {
8548             # html2text found, run it
8549             $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
8550             $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
8551                 unless defined($saved_file);
8552
8553             local *README;
8554             $pid = open README, "$html_converter $saved_file |"
8555               or $CPAN::Frontend->mydie(qq{
8556 Could not fork '$html_converter $saved_file': $!});
8557             my($fh,$filename);
8558             if ($CPAN::META->has_inst("File::Temp")) {
8559                 $fh = File::Temp->new(
8560                                       template => 'cpan_htmlconvert_XXXX',
8561                                       suffix => '.txt',
8562                                       unlink => 0,
8563                                      );
8564                 $filename = $fh->filename;
8565             } else {
8566                 $filename = "cpan_htmlconvert_$$.txt";
8567                 $fh = FileHandle->new();
8568                 open $fh, ">$filename" or die;
8569             }
8570             while (<README>) {
8571                 $fh->print($_);
8572             }
8573             close README or
8574                 $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
8575             my $tmpin = $fh->filename;
8576             $CPAN::Frontend->myprint(sprintf(qq{
8577 Run '%s %s' and
8578 saved output to %s\n},
8579                                              $html_converter,
8580                                              $saved_file,
8581                                              $tmpin,
8582                                             )) if $CPAN::DEBUG;
8583             close $fh;
8584             local *FH;
8585             open FH, $tmpin
8586                 or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
8587             my $fh_pager = FileHandle->new;
8588             local($SIG{PIPE}) = "IGNORE";
8589             my $pager = $CPAN::Config->{'pager'} || "cat";
8590             $fh_pager->open("|$pager")
8591                 or $CPAN::Frontend->mydie(qq{
8592 Could not open pager '$pager': $!});
8593             $CPAN::Frontend->myprint(qq{
8594 Displaying URL
8595   $url
8596 with pager "$pager"
8597 });
8598             $CPAN::Frontend->mysleep(1);
8599             $fh_pager->print(<FH>);
8600             $fh_pager->close;
8601         } else {
8602             # coldn't find the web browser or html converter
8603             $CPAN::Frontend->myprint(qq{
8604 You need to install lynx or $html_converter to use this feature.});
8605         }
8606     }
8607 }
8608
8609 #-> sub CPAN::Distribution::_getsave_url ;
8610 sub _getsave_url {
8611     my($dist, $shell, $url) = @_;
8612
8613     $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
8614       if $CPAN::DEBUG;
8615
8616     my($fh,$filename);
8617     if ($CPAN::META->has_inst("File::Temp")) {
8618         $fh = File::Temp->new(
8619                               template => "cpan_getsave_url_XXXX",
8620                               suffix => ".html",
8621                               unlink => 0,
8622                              );
8623         $filename = $fh->filename;
8624     } else {
8625         $fh = FileHandle->new;
8626         $filename = "cpan_getsave_url_$$.html";
8627     }
8628     my $tmpin = $filename;
8629     if ($CPAN::META->has_usable('LWP')) {
8630         $CPAN::Frontend->myprint("Fetching with LWP:
8631   $url
8632 ");
8633         my $Ua;
8634         CPAN::LWP::UserAgent->config;
8635         eval { $Ua = CPAN::LWP::UserAgent->new; };
8636         if ($@) {
8637             $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
8638             return;
8639         } else {
8640             my($var);
8641             $Ua->proxy('http', $var)
8642                 if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
8643             $Ua->no_proxy($var)
8644                 if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
8645         }
8646
8647         my $req = HTTP::Request->new(GET => $url);
8648         $req->header('Accept' => 'text/html');
8649         my $res = $Ua->request($req);
8650         if ($res->is_success) {
8651             $CPAN::Frontend->myprint(" + request successful.\n")
8652                 if $CPAN::DEBUG;
8653             print $fh $res->content;
8654             close $fh;
8655             $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
8656                 if $CPAN::DEBUG;
8657             return $tmpin;
8658         } else {
8659             $CPAN::Frontend->myprint(sprintf(
8660                                              "LWP failed with code[%s], message[%s]\n",
8661                                              $res->code,
8662                                              $res->message,
8663                                             ));
8664             return;
8665         }
8666     } else {
8667         $CPAN::Frontend->mywarn("  LWP not available\n");
8668         return;
8669     }
8670 }
8671
8672 # sub CPAN::Distribution::_build_command
8673 sub _build_command {
8674     my($self) = @_;
8675     if ($^O eq "MSWin32") { # special code needed at least up to
8676                             # Module::Build 0.2611 and 0.2706; a fix
8677                             # in M:B has been promised 2006-01-30
8678         my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
8679         return "$perl ./Build";
8680     }
8681     return "./Build";
8682 }
8683
8684 package CPAN::Bundle;
8685 use strict;
8686
8687 sub look {
8688     my $self = shift;
8689     $CPAN::Frontend->myprint($self->as_string);
8690 }
8691
8692 #-> CPAN::Bundle::undelay
8693 sub undelay {
8694     my $self = shift;
8695     delete $self->{later};
8696     for my $c ( $self->contains ) {
8697         my $obj = CPAN::Shell->expandany($c) or next;
8698         $obj->undelay;
8699     }
8700 }
8701
8702 # mark as dirty/clean
8703 #-> sub CPAN::Bundle::color_cmd_tmps ;
8704 sub color_cmd_tmps {
8705     my($self) = shift;
8706     my($depth) = shift || 0;
8707     my($color) = shift || 0;
8708     my($ancestors) = shift || [];
8709     # a module needs to recurse to its cpan_file, a distribution needs
8710     # to recurse into its prereq_pms, a bundle needs to recurse into its modules
8711
8712     return if exists $self->{incommandcolor}
8713         && $color==1
8714         && $self->{incommandcolor}==$color;
8715     if ($depth>=$CPAN::MAX_RECURSION){
8716         die(CPAN::Exception::RecursiveDependency->new($ancestors));
8717     }
8718     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
8719
8720     for my $c ( $self->contains ) {
8721         my $obj = CPAN::Shell->expandany($c) or next;
8722         CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
8723         $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
8724     }
8725     # never reached code?
8726     #if ($color==0) {
8727       #delete $self->{badtestcnt};
8728     #}
8729     $self->{incommandcolor} = $color;
8730 }
8731
8732 #-> sub CPAN::Bundle::as_string ;
8733 sub as_string {
8734     my($self) = @_;
8735     $self->contains;
8736     # following line must be "=", not "||=" because we have a moving target
8737     $self->{INST_VERSION} = $self->inst_version;
8738     return $self->SUPER::as_string;
8739 }
8740
8741 #-> sub CPAN::Bundle::contains ;
8742 sub contains {
8743     my($self) = @_;
8744     my($inst_file) = $self->inst_file || "";
8745     my($id) = $self->id;
8746     $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
8747     if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
8748         undef $inst_file;
8749     }
8750     unless ($inst_file) {
8751         # Try to get at it in the cpan directory
8752         $self->debug("no inst_file") if $CPAN::DEBUG;
8753         my $cpan_file;
8754         $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless
8755               $cpan_file = $self->cpan_file;
8756         if ($cpan_file eq "N/A") {
8757             $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN.
8758   Maybe stale symlink? Maybe removed during session? Giving up.\n");
8759         }
8760         my $dist = $CPAN::META->instance('CPAN::Distribution',
8761                                          $self->cpan_file);
8762         $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
8763         $dist->get;
8764         $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
8765         my($todir) = $CPAN::Config->{'cpan_home'};
8766         my(@me,$from,$to,$me);
8767         @me = split /::/, $self->id;
8768         $me[-1] .= ".pm";
8769         $me = File::Spec->catfile(@me);
8770         $from = $self->find_bundle_file($dist->{build_dir},join('/',@me));
8771         $to = File::Spec->catfile($todir,$me);
8772         File::Path::mkpath(File::Basename::dirname($to));
8773         File::Copy::copy($from, $to)
8774               or Carp::confess("Couldn't copy $from to $to: $!");
8775         $inst_file = $to;
8776     }
8777     my @result;
8778     my $fh = FileHandle->new;
8779     local $/ = "\n";
8780     open($fh,$inst_file) or die "Could not open '$inst_file': $!";
8781     my $in_cont = 0;
8782     $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
8783     while (<$fh>) {
8784         $in_cont = m/^=(?!head1\s+CONTENTS)/ ? 0 :
8785             m/^=head1\s+CONTENTS/ ? 1 : $in_cont;
8786         next unless $in_cont;
8787         next if /^=/;
8788         s/\#.*//;
8789         next if /^\s+$/;
8790         chomp;
8791         push @result, (split " ", $_, 2)[0];
8792     }
8793     close $fh;
8794     delete $self->{STATUS};
8795     $self->{CONTAINS} = \@result;
8796     $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
8797     unless (@result) {
8798         $CPAN::Frontend->mywarn(qq{
8799 The bundle file "$inst_file" may be a broken
8800 bundlefile. It seems not to contain any bundle definition.
8801 Please check the file and if it is bogus, please delete it.
8802 Sorry for the inconvenience.
8803 });
8804     }
8805     @result;
8806 }
8807
8808 #-> sub CPAN::Bundle::find_bundle_file
8809 # $where is in local format, $what is in unix format
8810 sub find_bundle_file {
8811     my($self,$where,$what) = @_;
8812     $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
8813 ### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
8814 ###    my $bu = File::Spec->catfile($where,$what);
8815 ###    return $bu if -f $bu;
8816     my $manifest = File::Spec->catfile($where,"MANIFEST");
8817     unless (-f $manifest) {
8818         require ExtUtils::Manifest;
8819         my $cwd = CPAN::anycwd();
8820         $self->safe_chdir($where);
8821         ExtUtils::Manifest::mkmanifest();
8822         $self->safe_chdir($cwd);
8823     }
8824     my $fh = FileHandle->new($manifest)
8825         or Carp::croak("Couldn't open $manifest: $!");
8826     local($/) = "\n";
8827     my $bundle_filename = $what;
8828     $bundle_filename =~ s|Bundle.*/||;
8829     my $bundle_unixpath;
8830     while (<$fh>) {
8831         next if /^\s*\#/;
8832         my($file) = /(\S+)/;
8833         if ($file =~ m|\Q$what\E$|) {
8834             $bundle_unixpath = $file;
8835             # return File::Spec->catfile($where,$bundle_unixpath); # bad
8836             last;
8837         }
8838         # retry if she managed to have no Bundle directory
8839         $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
8840     }
8841     return File::Spec->catfile($where, split /\//, $bundle_unixpath)
8842         if $bundle_unixpath;
8843     Carp::croak("Couldn't find a Bundle file in $where");
8844 }
8845
8846 # needs to work quite differently from Module::inst_file because of
8847 # cpan_home/Bundle/ directory and the possibility that we have
8848 # shadowing effect. As it makes no sense to take the first in @INC for
8849 # Bundles, we parse them all for $VERSION and take the newest.
8850
8851 #-> sub CPAN::Bundle::inst_file ;
8852 sub inst_file {
8853     my($self) = @_;
8854     my($inst_file);
8855     my(@me);
8856     @me = split /::/, $self->id;
8857     $me[-1] .= ".pm";
8858     my($incdir,$bestv);
8859     foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
8860         my $bfile = File::Spec->catfile($incdir, @me);
8861         CPAN->debug("bfile[$bfile]") if $CPAN::DEBUG;
8862         next unless -f $bfile;
8863         my $foundv = MM->parse_version($bfile);
8864         if (!$bestv || CPAN::Version->vgt($foundv,$bestv)) {
8865             $self->{INST_FILE} = $bfile;
8866             $self->{INST_VERSION} = $bestv = $foundv;
8867         }
8868     }
8869     $self->{INST_FILE};
8870 }
8871
8872 #-> sub CPAN::Bundle::inst_version ;
8873 sub inst_version {
8874     my($self) = @_;
8875     $self->inst_file; # finds INST_VERSION as side effect
8876     $self->{INST_VERSION};
8877 }
8878
8879 #-> sub CPAN::Bundle::rematein ;
8880 sub rematein {
8881     my($self,$meth) = @_;
8882     $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
8883     my($id) = $self->id;
8884     Carp::croak "Can't $meth $id, don't have an associated bundle file. :-(\n"
8885         unless $self->inst_file || $self->cpan_file;
8886     my($s,%fail);
8887     for $s ($self->contains) {
8888         my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
8889             $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
8890         if ($type eq 'CPAN::Distribution') {
8891             $CPAN::Frontend->mywarn(qq{
8892 The Bundle }.$self->id.qq{ contains
8893 explicitly a file '$s'.
8894 Going to $meth that.
8895 });
8896             $CPAN::Frontend->mysleep(5);
8897         }
8898         # possibly noisy action:
8899         $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
8900         my $obj = $CPAN::META->instance($type,$s);
8901         $obj->{reqtype} = $self->{reqtype};
8902         $obj->$meth();
8903     }
8904 }
8905
8906 # If a bundle contains another that contains an xs_file we have here,
8907 # we just don't bother I suppose
8908 #-> sub CPAN::Bundle::xs_file
8909 sub xs_file {
8910     return 0;
8911 }
8912
8913 #-> sub CPAN::Bundle::force ;
8914 sub fforce   { shift->rematein('fforce',@_); }
8915 #-> sub CPAN::Bundle::force ;
8916 sub force   { shift->rematein('force',@_); }
8917 #-> sub CPAN::Bundle::notest ;
8918 sub notest  { shift->rematein('notest',@_); }
8919 #-> sub CPAN::Bundle::get ;
8920 sub get     { shift->rematein('get',@_); }
8921 #-> sub CPAN::Bundle::make ;
8922 sub make    { shift->rematein('make',@_); }
8923 #-> sub CPAN::Bundle::test ;
8924 sub test    {
8925     my $self = shift;
8926     # $self->{badtestcnt} ||= 0;
8927     $self->rematein('test',@_);
8928 }
8929 #-> sub CPAN::Bundle::install ;
8930 sub install {
8931   my $self = shift;
8932   $self->rematein('install',@_);
8933 }
8934 #-> sub CPAN::Bundle::clean ;
8935 sub clean   { shift->rematein('clean',@_); }
8936
8937 #-> sub CPAN::Bundle::uptodate ;
8938 sub uptodate {
8939     my($self) = @_;
8940     return 0 unless $self->SUPER::uptodate; # we mut have the current Bundle def
8941     my $c;
8942     foreach $c ($self->contains) {
8943         my $obj = CPAN::Shell->expandany($c);
8944         return 0 unless $obj->uptodate;
8945     }
8946     return 1;
8947 }
8948
8949 #-> sub CPAN::Bundle::readme ;
8950 sub readme  {
8951     my($self) = @_;
8952     my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
8953 No File found for bundle } . $self->id . qq{\n}), return;
8954     $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
8955     $CPAN::META->instance('CPAN::Distribution',$file)->readme;
8956 }
8957
8958 package CPAN::Module;
8959 use strict;
8960
8961 # Accessors
8962 # sub CPAN::Module::userid
8963 sub userid {
8964     my $self = shift;
8965     my $ro = $self->ro;
8966     return unless $ro;
8967     return $ro->{userid} || $ro->{CPAN_USERID};
8968 }
8969 # sub CPAN::Module::description
8970 sub description {
8971     my $self = shift;
8972     my $ro = $self->ro or return "";
8973     $ro->{description}
8974 }
8975
8976 sub distribution {
8977     my($self) = @_;
8978     CPAN::Shell->expand("Distribution",$self->cpan_file);
8979 }
8980
8981 # sub CPAN::Module::undelay
8982 sub undelay {
8983     my $self = shift;
8984     delete $self->{later};
8985     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
8986         $dist->undelay;
8987     }
8988 }
8989
8990 # mark as dirty/clean
8991 #-> sub CPAN::Module::color_cmd_tmps ;
8992 sub color_cmd_tmps {
8993     my($self) = shift;
8994     my($depth) = shift || 0;
8995     my($color) = shift || 0;
8996     my($ancestors) = shift || [];
8997     # a module needs to recurse to its cpan_file
8998
8999     return if exists $self->{incommandcolor}
9000         && $color==1
9001         && $self->{incommandcolor}==$color;
9002     return if $color==0 && !$self->{incommandcolor};
9003     if ($color>=1) {
9004         if ( $self->uptodate ) {
9005             $self->{incommandcolor} = $color;
9006             return;
9007         } elsif (my $have_version = $self->available_version) {
9008             # maybe what we have is good enough
9009             if (@$ancestors) {
9010                 my $who_asked_for_me = $ancestors->[-1];
9011                 my $obj = CPAN::Shell->expandany($who_asked_for_me);
9012                 if (0) {
9013                 } elsif ($obj->isa("CPAN::Bundle")) {
9014                     # bundles cannot specify a minimum version
9015                     return;
9016                 } elsif ($obj->isa("CPAN::Distribution")) {
9017                     if (my $prereq_pm = $obj->prereq_pm) {
9018                         for my $k (keys %$prereq_pm) {
9019                             if (my $want_version = $prereq_pm->{$k}{$self->id}) {
9020                                 if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
9021                                     $self->{incommandcolor} = $color;
9022                                     return;
9023                                 }
9024                             }
9025                         }
9026                     }
9027                 }
9028             }
9029         }
9030     } else {
9031         $self->{incommandcolor} = $color; # set me before recursion,
9032                                           # so we can break it
9033     }
9034     if ($depth>=$CPAN::MAX_RECURSION){
9035         die(CPAN::Exception::RecursiveDependency->new($ancestors));
9036     }
9037     # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
9038
9039     if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
9040         $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
9041     }
9042     # unreached code?
9043     # if ($color==0) {
9044     #    delete $self->{badtestcnt};
9045     # }
9046     $self->{incommandcolor} = $color;
9047 }
9048
9049 #-> sub CPAN::Module::as_glimpse ;
9050 sub as_glimpse {
9051     my($self) = @_;
9052     my(@m);
9053     my $class = ref($self);
9054     $class =~ s/^CPAN:://;
9055     my $color_on = "";
9056     my $color_off = "";
9057     if (
9058         $CPAN::Shell::COLOR_REGISTERED
9059         &&
9060         $CPAN::META->has_inst("Term::ANSIColor")
9061         &&
9062         $self->description
9063        ) {
9064         $color_on = Term::ANSIColor::color("green");
9065         $color_off = Term::ANSIColor::color("reset");
9066     }
9067     my $uptodateness = " ";
9068     if ($class eq "Bundle") {
9069     } elsif ($self->uptodate) {
9070         $uptodateness = "=";
9071     } elsif ($self->inst_version) {
9072         $uptodateness = "<";
9073     }
9074     push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
9075                      $class,
9076                      $uptodateness,
9077                      $color_on,
9078                      $self->id,
9079                      $color_off,
9080                      ($self->distribution ?
9081                       $self->distribution->pretty_id :
9082                       $self->cpan_userid
9083                      ),
9084                     );
9085     join "", @m;
9086 }
9087
9088 #-> sub CPAN::Module::dslip_status
9089 sub dslip_status {
9090     my($self) = @_;
9091     my($stat);
9092     # development status
9093     @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
9094                                               pre-alpha alpha beta released
9095                                               mature standard,;
9096     # support level
9097     @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
9098                                               developer comp.lang.perl.*
9099                                               none abandoned,;
9100     # language
9101     @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
9102     # interface
9103     @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
9104                                               references+ties
9105                                               object-oriented pragma
9106                                               hybrid none,;
9107     # public licence
9108     @{$stat->{P}}{qw,p g l b a o d r n,} = qw,Standard-Perl
9109                                               GPL LGPL
9110                                               BSD Artistic
9111                                               open-source
9112                                               distribution_allowed
9113                                               restricted_distribution
9114                                               no_licence,;
9115     for my $x (qw(d s l i p)) {
9116         $stat->{$x}{' '} = 'unknown';
9117         $stat->{$x}{'?'} = 'unknown';
9118     }
9119     my $ro = $self->ro;
9120     return +{} unless $ro && $ro->{statd};
9121     return {
9122             D  => $ro->{statd},
9123             S  => $ro->{stats},
9124             L  => $ro->{statl},
9125             I  => $ro->{stati},
9126             P  => $ro->{statp},
9127             DV => $stat->{D}{$ro->{statd}},
9128             SV => $stat->{S}{$ro->{stats}},
9129             LV => $stat->{L}{$ro->{statl}},
9130             IV => $stat->{I}{$ro->{stati}},
9131             PV => $stat->{P}{$ro->{statp}},
9132            };
9133 }
9134
9135 #-> sub CPAN::Module::as_string ;
9136 sub as_string {
9137     my($self) = @_;
9138     my(@m);
9139     CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
9140     my $class = ref($self);
9141     $class =~ s/^CPAN:://;
9142     local($^W) = 0;
9143     push @m, $class, " id = $self->{ID}\n";
9144     my $sprintf = "    %-12s %s\n";
9145     push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
9146         if $self->description;
9147     my $sprintf2 = "    %-12s %s (%s)\n";
9148     my($userid);
9149     $userid = $self->userid;
9150     if ( $userid ){
9151         my $author;
9152         if ($author = CPAN::Shell->expand('Author',$userid)) {
9153           my $email = "";
9154           my $m; # old perls
9155           if ($m = $author->email) {
9156             $email = " <$m>";
9157           }
9158           push @m, sprintf(
9159                            $sprintf2,
9160                            'CPAN_USERID',
9161                            $userid,
9162                            $author->fullname . $email
9163                           );
9164         }
9165     }
9166     push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
9167         if $self->cpan_version;
9168     if (my $cpan_file = $self->cpan_file){
9169         push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
9170         if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
9171             my $upload_date = $dist->upload_date;
9172             if ($upload_date) {
9173                 push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
9174             }
9175         }
9176     }
9177     my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
9178     my $dslip = $self->dslip_status;
9179     push @m, sprintf(
9180                      $sprintf3,
9181                      'DSLIP_STATUS',
9182                      @{$dslip}{qw(D S L I P DV SV LV IV PV)},
9183                     ) if $dslip->{D};
9184     my $local_file = $self->inst_file;
9185     unless ($self->{MANPAGE}) {
9186         my $manpage;
9187         if ($local_file) {
9188             $manpage = $self->manpage_headline($local_file);
9189         } else {
9190             # If we have already untarred it, we should look there
9191             my $dist = $CPAN::META->instance('CPAN::Distribution',
9192                                              $self->cpan_file);
9193             # warn "dist[$dist]";
9194             # mff=manifest file; mfh=manifest handle
9195             my($mff,$mfh);
9196             if (
9197                 $dist->{build_dir}
9198                 and
9199                 (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
9200                 and
9201                 $mfh = FileHandle->new($mff)
9202                ) {
9203                 CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
9204                 my $lfre = $self->id; # local file RE
9205                 $lfre =~ s/::/./g;
9206                 $lfre .= "\\.pm\$";
9207                 my($lfl); # local file file
9208                 local $/ = "\n";
9209                 my(@mflines) = <$mfh>;
9210                 for (@mflines) {
9211                     s/^\s+//;
9212                     s/\s.*//s;
9213                 }
9214                 while (length($lfre)>5 and !$lfl) {
9215                     ($lfl) = grep /$lfre/, @mflines;
9216                     CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
9217                     $lfre =~ s/.+?\.//;
9218                 }
9219                 $lfl =~ s/\s.*//; # remove comments
9220                 $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
9221                 my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
9222                 # warn "lfl_abs[$lfl_abs]";
9223                 if (-f $lfl_abs) {
9224                     $manpage = $self->manpage_headline($lfl_abs);
9225                 }
9226             }
9227         }
9228         $self->{MANPAGE} = $manpage if $manpage;
9229     }
9230     my($item);
9231     for $item (qw/MANPAGE/) {
9232         push @m, sprintf($sprintf, $item, $self->{$item})
9233             if exists $self->{$item};
9234     }
9235     for $item (qw/CONTAINS/) {
9236         push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
9237             if exists $self->{$item} && @{$self->{$item}};
9238     }
9239     push @m, sprintf($sprintf, 'INST_FILE',
9240                      $local_file || "(not installed)");
9241     push @m, sprintf($sprintf, 'INST_VERSION',
9242                      $self->inst_version) if $local_file;
9243     join "", @m, "\n";
9244 }
9245
9246 sub manpage_headline {
9247   my($self,$local_file) = @_;
9248   my(@local_file) = $local_file;
9249   $local_file =~ s/\.pm(?!\n)\Z/.pod/;
9250   push @local_file, $local_file;
9251   my(@result,$locf);
9252   for $locf (@local_file) {
9253     next unless -f $locf;
9254     my $fh = FileHandle->new($locf)
9255         or $Carp::Frontend->mydie("Couldn't open $locf: $!");
9256     my $inpod = 0;
9257     local $/ = "\n";
9258     while (<$fh>) {
9259       $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
9260           m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
9261       next unless $inpod;
9262       next if /^=/;
9263       next if /^\s+$/;
9264       chomp;
9265       push @result, $_;
9266     }
9267     close $fh;
9268     last if @result;
9269   }
9270   for (@result) {
9271       s/^\s+//;
9272       s/\s+$//;
9273   }
9274   join " ", @result;
9275 }
9276
9277 #-> sub CPAN::Module::cpan_file ;
9278 # Note: also inherited by CPAN::Bundle
9279 sub cpan_file {
9280     my $self = shift;
9281     # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
9282     unless ($self->ro) {
9283         CPAN::Index->reload;
9284     }
9285     my $ro = $self->ro;
9286     if ($ro && defined $ro->{CPAN_FILE}){
9287         return $ro->{CPAN_FILE};
9288     } else {
9289         my $userid = $self->userid;
9290         if ( $userid ) {
9291             if ($CPAN::META->exists("CPAN::Author",$userid)) {
9292                 my $author = $CPAN::META->instance("CPAN::Author",
9293                                                    $userid);
9294                 my $fullname = $author->fullname;
9295                 my $email = $author->email;
9296                 unless (defined $fullname && defined $email) {
9297                     return sprintf("Contact Author %s",
9298                                    $userid,
9299                                   );
9300                 }
9301                 return "Contact Author $fullname <$email>";
9302             } else {
9303                 return "Contact Author $userid (Email address not available)";
9304             }
9305         } else {
9306             return "N/A";
9307         }
9308     }
9309 }
9310
9311 #-> sub CPAN::Module::cpan_version ;
9312 sub cpan_version {
9313     my $self = shift;
9314
9315     my $ro = $self->ro;
9316     unless ($ro) {
9317         # Can happen with modules that are not on CPAN
9318         $ro = {};
9319     }
9320     $ro->{CPAN_VERSION} = 'undef'
9321         unless defined $ro->{CPAN_VERSION};
9322     $ro->{CPAN_VERSION};
9323 }
9324
9325 #-> sub CPAN::Module::force ;
9326 sub force {
9327     my($self) = @_;
9328     $self->{force_update} = 1;
9329 }
9330
9331 #-> sub CPAN::Module::fforce ;
9332 sub fforce {
9333     my($self) = @_;
9334     $self->{force_update} = 2;
9335 }
9336
9337 #-> sub CPAN::Module::notest ;
9338 sub notest {
9339     my($self) = @_;
9340     # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
9341     $self->{notest}++;
9342 }
9343
9344 #-> sub CPAN::Module::rematein ;
9345 sub rematein {
9346     my($self,$meth) = @_;
9347     $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
9348                                      $meth,
9349                                      $self->id));
9350     my $cpan_file = $self->cpan_file;
9351     if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/){
9352       $CPAN::Frontend->mywarn(sprintf qq{
9353   The module %s isn\'t available on CPAN.
9354
9355   Either the module has not yet been uploaded to CPAN, or it is
9356   temporary unavailable. Please contact the author to find out
9357   more about the status. Try 'i %s'.
9358 },
9359                               $self->id,
9360                               $self->id,
9361                              );
9362       return;
9363     }
9364     my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
9365     $pack->called_for($self->id);
9366     if (exists $self->{force_update}){
9367         if ($self->{force_update} == 2) {
9368             $pack->fforce($meth);
9369         } else {
9370             $pack->force($meth);
9371         }
9372     }
9373     $pack->notest($meth) if exists $self->{notest} && $self->{notest};
9374
9375     $pack->{reqtype} ||= "";
9376     CPAN->debug("dist-reqtype[$pack->{reqtype}]".
9377                 "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
9378         if ($pack->{reqtype}) {
9379             if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
9380                 $pack->{reqtype} = $self->{reqtype};
9381                 if (
9382                     exists $pack->{install}
9383                     &&
9384                     (
9385                      UNIVERSAL::can($pack->{install},"failed") ?
9386                      $pack->{install}->failed :
9387                      $pack->{install} =~ /^NO/
9388                     )
9389                    ) {
9390                     delete $pack->{install};
9391                     $CPAN::Frontend->mywarn
9392                         ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
9393                 }
9394             }
9395         } else {
9396             $pack->{reqtype} = $self->{reqtype};
9397         }
9398
9399     my $success = eval {
9400         $pack->$meth();
9401     };
9402     my $err = $@;
9403     $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
9404     $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
9405     delete $self->{force_update};
9406     delete $self->{notest};
9407     if ($err) {
9408         die $err;
9409     }
9410     return $success;
9411 }
9412
9413 #-> sub CPAN::Module::perldoc ;
9414 sub perldoc { shift->rematein('perldoc') }
9415 #-> sub CPAN::Module::readme ;
9416 sub readme  { shift->rematein('readme') }
9417 #-> sub CPAN::Module::look ;
9418 sub look    { shift->rematein('look') }
9419 #-> sub CPAN::Module::cvs_import ;
9420 sub cvs_import { shift->rematein('cvs_import') }
9421 #-> sub CPAN::Module::get ;
9422 sub get     { shift->rematein('get',@_) }
9423 #-> sub CPAN::Module::make ;
9424 sub make    { shift->rematein('make') }
9425 #-> sub CPAN::Module::test ;
9426 sub test   {
9427     my $self = shift;
9428     # $self->{badtestcnt} ||= 0;
9429     $self->rematein('test',@_);
9430 }
9431 #-> sub CPAN::Module::uptodate ;
9432 sub uptodate {
9433     my($self) = @_;
9434     local($_); # protect against a bug in MakeMaker 6.17
9435     my($latest) = $self->cpan_version;
9436     $latest ||= 0;
9437     my($inst_file) = $self->inst_file;
9438     my($have) = 0;
9439     if (defined $inst_file) {
9440         $have = $self->inst_version;
9441     }
9442     local($^W)=0;
9443     if ($inst_file
9444         &&
9445         ! CPAN::Version->vgt($latest, $have)
9446        ) {
9447         CPAN->debug("returning uptodate. inst_file[$inst_file] ".
9448                     "latest[$latest] have[$have]") if $CPAN::DEBUG;
9449         return 1;
9450     }
9451     return;
9452 }
9453 #-> sub CPAN::Module::install ;
9454 sub install {
9455     my($self) = @_;
9456     my($doit) = 0;
9457     if ($self->uptodate
9458         &&
9459         not exists $self->{force_update}
9460        ) {
9461         $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
9462                                          $self->id,
9463                                          $self->inst_version,
9464                                         ));
9465     } else {
9466         $doit = 1;
9467     }
9468     my $ro = $self->ro;
9469     if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
9470         $CPAN::Frontend->mywarn(qq{
9471 \n\n\n     ***WARNING***
9472      The module $self->{ID} has no active maintainer.\n\n\n
9473 });
9474         $CPAN::Frontend->mysleep(5);
9475     }
9476     $self->rematein('install') if $doit;
9477 }
9478 #-> sub CPAN::Module::clean ;
9479 sub clean  { shift->rematein('clean') }
9480
9481 #-> sub CPAN::Module::inst_file ;
9482 sub inst_file {
9483     my($self) = @_;
9484     $self->_file_in_path([@INC]);
9485 }
9486
9487 #-> sub CPAN::Module::available_file ;
9488 sub available_file {
9489     my($self) = @_;
9490     my $sep = $Config::Config{path_sep};
9491     my $perllib = $ENV{PERL5LIB};
9492     $perllib = $ENV{PERLLIB} unless defined $perllib;
9493     my @perllib = split(/$sep/,$perllib) if defined $perllib;
9494     $self->_file_in_path([@perllib,@INC]);
9495 }
9496
9497 #-> sub CPAN::Module::file_in_path ;
9498 sub _file_in_path {
9499     my($self,$path) = @_;
9500     my($dir,@packpath);
9501     @packpath = split /::/, $self->{ID};
9502     $packpath[-1] .= ".pm";
9503     if (@packpath == 1 && $packpath[0] eq "readline.pm") {
9504         unshift @packpath, "Term", "ReadLine"; # historical reasons
9505     }
9506     foreach $dir (@$path) {
9507         my $pmfile = File::Spec->catfile($dir,@packpath);
9508         if (-f $pmfile){
9509             return $pmfile;
9510         }
9511     }
9512     return;
9513 }
9514
9515 #-> sub CPAN::Module::xs_file ;
9516 sub xs_file {
9517     my($self) = @_;
9518     my($dir,@packpath);
9519     @packpath = split /::/, $self->{ID};
9520     push @packpath, $packpath[-1];
9521     $packpath[-1] .= "." . $Config::Config{'dlext'};
9522     foreach $dir (@INC) {
9523         my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
9524         if (-f $xsfile){
9525             return $xsfile;
9526         }
9527     }
9528     return;
9529 }
9530
9531 #-> sub CPAN::Module::inst_version ;
9532 sub inst_version {
9533     my($self) = @_;
9534     my $parsefile = $self->inst_file or return;
9535     my $have = $self->parse_version($parsefile);
9536     $have;
9537 }
9538
9539 #-> sub CPAN::Module::inst_version ;
9540 sub available_version {
9541     my($self) = @_;
9542     my $parsefile = $self->available_file or return;
9543     my $have = $self->parse_version($parsefile);
9544     $have;
9545 }
9546
9547 #-> sub CPAN::Module::parse_version ;
9548 sub parse_version {
9549     my($self,$parsefile) = @_;
9550     my $have = MM->parse_version($parsefile);
9551     $have = "undef" unless defined $have && length $have;
9552     $have =~ s/^ //; # since the %vd hack these two lines here are needed
9553     $have =~ s/ $//; # trailing whitespace happens all the time
9554
9555     $have = CPAN::Version->readable($have);
9556
9557     $have =~ s/\s*//g; # stringify to float around floating point issues
9558     $have; # no stringify needed, \s* above matches always
9559 }
9560
9561 package CPAN;
9562 use strict;
9563
9564 1;
9565
9566
9567 __END__
9568
9569 =head1 NAME
9570
9571 CPAN - query, download and build perl modules from CPAN sites
9572
9573 =head1 SYNOPSIS
9574
9575 Interactive mode:
9576
9577   perl -MCPAN -e shell
9578
9579 --or--
9580
9581   cpan
9582
9583 Basic commands:
9584
9585   # Modules:
9586
9587   cpan> install Acme::Meta                       # in the shell
9588
9589   CPAN::Shell->install("Acme::Meta");            # in perl
9590
9591   # Distributions:
9592
9593   cpan> install NWCLARK/Acme-Meta-0.02.tar.gz    # in the shell
9594
9595   CPAN::Shell->
9596     install("NWCLARK/Acme-Meta-0.02.tar.gz");    # in perl
9597
9598   # module objects:
9599
9600   $mo = CPAN::Shell->expandany($mod);
9601   $mo = CPAN::Shell->expand("Module",$mod);      # same thing
9602
9603   # distribution objects:
9604
9605   $do = CPAN::Shell->expand("Module",$mod)->distribution;
9606   $do = CPAN::Shell->expandany($distro);         # same thing
9607   $do = CPAN::Shell->expand("Distribution",
9608                             $distro);            # same thing
9609
9610 =head1 DESCRIPTION
9611
9612 The CPAN module automates or at least simplifies the make and install
9613 of perl modules and extensions. It includes some primitive searching
9614 capabilities and knows how to use Net::FTP or LWP or some external
9615 download clients to fetch the distributions from the net.
9616
9617 These are fetched from one or more of the mirrored CPAN (Comprehensive
9618 Perl Archive Network) sites and unpacked in a dedicated directory.
9619
9620 The CPAN module also supports the concept of named and versioned
9621 I<bundles> of modules. Bundles simplify the handling of sets of
9622 related modules. See Bundles below.
9623
9624 The package contains a session manager and a cache manager. The
9625 session manager keeps track of what has been fetched, built and
9626 installed in the current session. The cache manager keeps track of the
9627 disk space occupied by the make processes and deletes excess space
9628 according to a simple FIFO mechanism.
9629
9630 All methods provided are accessible in a programmer style and in an
9631 interactive shell style.
9632
9633 =head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
9634
9635 The interactive mode is entered by running
9636
9637     perl -MCPAN -e shell
9638
9639 or
9640
9641     cpan
9642
9643 which puts you into a readline interface. If C<Term::ReadKey> and
9644 either C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed
9645 it supports both history and command completion.
9646
9647 Once you are on the command line, type C<h> to get a one page help
9648 screen and the rest should be self-explanatory.
9649
9650 The function call C<shell> takes two optional arguments, one is the
9651 prompt, the second is the default initial command line (the latter
9652 only works if a real ReadLine interface module is installed).
9653
9654 The most common uses of the interactive modes are
9655
9656 =over 2
9657
9658 =item Searching for authors, bundles, distribution files and modules
9659
9660 There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
9661 for each of the four categories and another, C<i> for any of the
9662 mentioned four. Each of the four entities is implemented as a class
9663 with slightly differing methods for displaying an object.
9664
9665 Arguments you pass to these commands are either strings exactly matching
9666 the identification string of an object or regular expressions that are
9667 then matched case-insensitively against various attributes of the
9668 objects. The parser recognizes a regular expression only if you
9669 enclose it between two slashes.
9670
9671 The principle is that the number of found objects influences how an
9672 item is displayed. If the search finds one item, the result is
9673 displayed with the rather verbose method C<as_string>, but if we find
9674 more than one, we display each object with the terse method
9675 C<as_glimpse>.
9676
9677 =item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
9678
9679 These commands take any number of arguments and investigate what is
9680 necessary to perform the action. If the argument is a distribution
9681 file name (recognized by embedded slashes), it is processed. If it is
9682 a module, CPAN determines the distribution file in which this module
9683 is included and processes that, following any dependencies named in
9684 the module's META.yml or Makefile.PL (this behavior is controlled by
9685 the configuration parameter C<prerequisites_policy>.)
9686
9687 C<get> downloads a distribution file and untars or unzips it, C<make>
9688 builds it, C<test> runs the test suite, and C<install> installs it.
9689
9690 Any C<make> or C<test> are run unconditionally. An
9691
9692   install <distribution_file>
9693
9694 also is run unconditionally. But for
9695
9696   install <module>
9697
9698 CPAN checks if an install is actually needed for it and prints
9699 I<module up to date> in the case that the distribution file containing
9700 the module doesn't need to be updated.
9701
9702 CPAN also keeps track of what it has done within the current session
9703 and doesn't try to build a package a second time regardless if it
9704 succeeded or not. It does not repeat a test run if the test
9705 has been run successfully before. Same for install runs.
9706
9707 The C<force> pragma may precede another command (currently: C<get>,
9708 C<make>, C<test>, or C<install>) and executes the command from scratch
9709 and tries to continue in case of some errors. See the section below on
9710 the C<force> and the C<fforce> pragma.
9711
9712 The C<notest> pragma may be used to skip the test part in the build
9713 process.
9714
9715 Example:
9716
9717     cpan> notest install Tk
9718
9719 A C<clean> command results in a
9720
9721   make clean
9722
9723 being executed within the distribution file's working directory.
9724
9725 =item C<readme>, C<perldoc>, C<look> module or distribution
9726
9727 C<readme> displays the README file of the associated distribution.
9728 C<Look> gets and untars (if not yet done) the distribution file,
9729 changes to the appropriate directory and opens a subshell process in
9730 that directory. C<perldoc> displays the pod documentation of the
9731 module in html or plain text format.
9732
9733 =item C<ls> author
9734
9735 =item C<ls> globbing_expression
9736
9737 The first form lists all distribution files in and below an author's
9738 CPAN directory as they are stored in the CHECKUMS files distributed on
9739 CPAN. The listing goes recursive into all subdirectories.
9740
9741 The second form allows to limit or expand the output with shell
9742 globbing as in the following examples:
9743
9744           ls JV/make*
9745           ls GSAR/*make*
9746           ls */*make*
9747
9748 The last example is very slow and outputs extra progress indicators
9749 that break the alignment of the result.
9750
9751 Note that globbing only lists directories explicitly asked for, for
9752 example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
9753 regarded as a bug and may be changed in future versions.
9754
9755 =item C<failed>
9756
9757 The C<failed> command reports all distributions that failed on one of
9758 C<make>, C<test> or C<install> for some reason in the currently
9759 running shell session.
9760
9761 =item Persistence between sessions
9762
9763 If the C<YAML> or the c<YAML::Syck> module is installed a record of
9764 the internal state of all modules is written to disk after each step.
9765 The files contain a signature of the currently running perl version
9766 for later perusal.
9767
9768 If the configurations variable C<build_dir_reuse> is set to a true
9769 value, then CPAN.pm reads the collected YAML files. If the stored
9770 signature matches the currently running perl the stored state is
9771 loaded into memory such that effectively persistence between sessions
9772 is established.
9773
9774 =item The C<force> and the C<fforce> pragma
9775
9776 To speed things up in complex installation scenarios, CPAN.pm keeps
9777 track of what it has already done and refuses to do some things a
9778 second time. A C<get>, a C<make>, and an C<install> are not repeated.
9779 A C<test> is only repeated if the previous test was unsuccessful. The
9780 diagnostic message when CPAN.pm refuses to do something a second time
9781 is one of I<Has already been >C<unwrapped|made|tested successfully> or
9782 something similar. Another situation where CPAN refuses to act is an
9783 C<install> if the according C<test> was not successful.
9784
9785 In all these cases, the user can override the goatish behaviour by
9786 prepending the command with the word force, for example:
9787
9788   cpan> force get Foo
9789   cpan> force make AUTHOR/Bar-3.14.tar.gz
9790   cpan> force test Baz
9791   cpan> force install Acme::Meta
9792
9793 Each I<forced> command is executed with the according part of its
9794 memory erased.
9795
9796 The C<fforce> pragma is a variant that emulates a C<force get> which
9797 erases the entire memory followed by the action specified, effectively
9798 restarting the whole get/make/test/install procedure from scratch.
9799
9800 =item Lockfile
9801
9802 Interactive sessions maintain a lockfile, per default C<~/.cpan/.lock>.
9803 Batch jobs can run without a lockfile and do not disturb each other.
9804
9805 The shell offers to run in I<degraded mode> when another process is
9806 holding the lockfile. This is an experimental feature that is not yet
9807 tested very well. This second shell then does not write the history
9808 file, does not use the metadata file and has a different prompt.
9809
9810 =item Signals
9811
9812 CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
9813 in the cpan-shell it is intended that you can press C<^C> anytime and
9814 return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
9815 to clean up and leave the shell loop. You can emulate the effect of a
9816 SIGTERM by sending two consecutive SIGINTs, which usually means by
9817 pressing C<^C> twice.
9818
9819 CPAN.pm ignores a SIGPIPE. If the user sets inactivity_timeout, a
9820 SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
9821 Build.PL> subprocess.
9822
9823 =back
9824
9825 =head2 CPAN::Shell
9826
9827 The commands that are available in the shell interface are methods in
9828 the package CPAN::Shell. If you enter the shell command, all your
9829 input is split by the Text::ParseWords::shellwords() routine which
9830 acts like most shells do. The first word is being interpreted as the
9831 method to be called and the rest of the words are treated as arguments
9832 to this method. Continuation lines are supported if a line ends with a
9833 literal backslash.
9834
9835 =head2 autobundle
9836
9837 C<autobundle> writes a bundle file into the
9838 C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
9839 a list of all modules that are both available from CPAN and currently
9840 installed within @INC. The name of the bundle file is based on the
9841 current date and a counter.
9842
9843 =head2 hosts
9844
9845 Note: this feature is still in alpha state and may change in future
9846 versions of CPAN.pm
9847
9848 This commands provides a statistical overview over recent download
9849 activities. The data for this is collected in the YAML file
9850 C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
9851 configured or YAML not installed, then no stats are provided.
9852
9853 =head2 mkmyconfig
9854
9855 mkmyconfig() writes your own CPAN::MyConfig file into your ~/.cpan/
9856 directory so that you can save your own preferences instead of the
9857 system wide ones.
9858
9859 =head2 recompile
9860
9861 recompile() is a very special command in that it takes no argument and
9862 runs the make/test/install cycle with brute force over all installed
9863 dynamically loadable extensions (aka XS modules) with 'force' in
9864 effect. The primary purpose of this command is to finish a network
9865 installation. Imagine, you have a common source tree for two different
9866 architectures. You decide to do a completely independent fresh
9867 installation. You start on one architecture with the help of a Bundle
9868 file produced earlier. CPAN installs the whole Bundle for you, but
9869 when you try to repeat the job on the second architecture, CPAN
9870 responds with a C<"Foo up to date"> message for all modules. So you
9871 invoke CPAN's recompile on the second architecture and you're done.
9872
9873 Another popular use for C<recompile> is to act as a rescue in case your
9874 perl breaks binary compatibility. If one of the modules that CPAN uses
9875 is in turn depending on binary compatibility (so you cannot run CPAN
9876 commands), then you should try the CPAN::Nox module for recovery.
9877
9878 =head2 report Bundle|Distribution|Module
9879
9880 The C<report> command temporarily turns on the C<test_report> config
9881 variable, then runs the C<force test> command with the given
9882 arguments. The C<force> pragma is used to re-run the tests and repeat
9883 every step that might have failed before.
9884
9885 =head2 upgrade [Module|/Regex/]...
9886
9887 The C<upgrade> command first runs an C<r> command with the given
9888 arguments and then installs the newest versions of all modules that
9889 were listed by that.
9890
9891 =head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
9892
9893 Although it may be considered internal, the class hierarchy does matter
9894 for both users and programmer. CPAN.pm deals with above mentioned four
9895 classes, and all those classes share a set of methods. A classical
9896 single polymorphism is in effect. A metaclass object registers all
9897 objects of all kinds and indexes them with a string. The strings
9898 referencing objects have a separated namespace (well, not completely
9899 separated):
9900
9901          Namespace                         Class
9902
9903    words containing a "/" (slash)      Distribution
9904     words starting with Bundle::          Bundle
9905           everything else            Module or Author
9906
9907 Modules know their associated Distribution objects. They always refer
9908 to the most recent official release. Developers may mark their releases
9909 as unstable development versions (by inserting an underbar into the
9910 module version number which will also be reflected in the distribution
9911 name when you run 'make dist'), so the really hottest and newest
9912 distribution is not always the default.  If a module Foo circulates
9913 on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
9914 way to install version 1.23 by saying
9915
9916     install Foo
9917
9918 This would install the complete distribution file (say
9919 BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
9920 like to install version 1.23_90, you need to know where the
9921 distribution file resides on CPAN relative to the authors/id/
9922 directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
9923 so you would have to say
9924
9925     install BAR/Foo-1.23_90.tar.gz
9926
9927 The first example will be driven by an object of the class
9928 CPAN::Module, the second by an object of class CPAN::Distribution.
9929
9930 =head2 Integrating local directories
9931
9932 Note: this feature is still in alpha state and may change in future
9933 versions of CPAN.pm
9934
9935 Distribution objects are normally distributions from the CPAN, but
9936 there is a slightly degenerate case for Distribution objects, too, of
9937 projects held on the local disk. These distribution objects have the
9938 same name as the local directory and end with a dot. A dot by itself
9939 is also allowed for the current directory at the time CPAN.pm was
9940 used. All actions such as C<make>, C<test>, and C<install> are applied
9941 directly to that directory. This gives the command C<cpan .> an
9942 interesting touch: while the normal mantra of installing a CPAN module
9943 without CPAN.pm is one of
9944
9945     perl Makefile.PL                 perl Build.PL
9946            ( go and get prerequisites )
9947     make                             ./Build
9948     make test                        ./Build test
9949     make install                     ./Build install
9950
9951 the command C<cpan .> does all of this at once. It figures out which
9952 of the two mantras is appropriate, fetches and installs all
9953 prerequisites, cares for them recursively and finally finishes the
9954 installation of the module in the current directory, be it a CPAN
9955 module or not.
9956
9957 The typical usage case is for private modules or working copies of
9958 projects from remote repositories on the local disk.
9959
9960 =head1 CONFIGURATION
9961
9962 When the CPAN module is used for the first time, a configuration
9963 dialog tries to determine a couple of site specific options. The
9964 result of the dialog is stored in a hash reference C< $CPAN::Config >
9965 in a file CPAN/Config.pm.
9966
9967 The default values defined in the CPAN/Config.pm file can be
9968 overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
9969 best placed in $HOME/.cpan/CPAN/MyConfig.pm, because $HOME/.cpan is
9970 added to the search path of the CPAN module before the use() or
9971 require() statements. The mkmyconfig command writes this file for you.
9972
9973 The C<o conf> command has various bells and whistles:
9974
9975 =over
9976
9977 =item completion support
9978
9979 If you have a ReadLine module installed, you can hit TAB at any point
9980 of the commandline and C<o conf> will offer you completion for the
9981 built-in subcommands and/or config variable names.
9982
9983 =item displaying some help: o conf help
9984
9985 Displays a short help
9986
9987 =item displaying current values: o conf [KEY]
9988
9989 Displays the current value(s) for this config variable. Without KEY
9990 displays all subcommands and config variables.
9991
9992 Example:
9993
9994   o conf shell
9995
9996 =item changing of scalar values: o conf KEY VALUE
9997
9998 Sets the config variable KEY to VALUE. The empty string can be
9999 specified as usual in shells, with C<''> or C<"">
10000
10001 Example:
10002
10003   o conf wget /usr/bin/wget
10004
10005 =item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
10006
10007 If a config variable name ends with C<list>, it is a list. C<o conf
10008 KEY shift> removes the first element of the list, C<o conf KEY pop>
10009 removes the last element of the list. C<o conf KEYS unshift LIST>
10010 prepends a list of values to the list, C<o conf KEYS push LIST>
10011 appends a list of valued to the list.
10012
10013 Likewise, C<o conf KEY splice LIST> passes the LIST to the according
10014 splice command.
10015
10016 Finally, any other list of arguments is taken as a new list value for
10017 the KEY variable discarding the previous value.
10018
10019 Examples:
10020
10021   o conf urllist unshift http://cpan.dev.local/CPAN
10022   o conf urllist splice 3 1
10023   o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
10024
10025 =item reverting to saved: o conf defaults
10026
10027 Reverts all config variables to the state in the saved config file.
10028
10029 =item saving the config: o conf commit
10030
10031 Saves all config variables to the current config file (CPAN/Config.pm
10032 or CPAN/MyConfig.pm that was loaded at start).
10033
10034 =back
10035
10036 The configuration dialog can be started any time later again by
10037 issuing the command C< o conf init > in the CPAN shell. A subset of
10038 the configuration dialog can be run by issuing C<o conf init WORD>
10039 where WORD is any valid config variable or a regular expression.
10040
10041 =head2 Config Variables
10042
10043 Currently the following keys in the hash reference $CPAN::Config are
10044 defined:
10045
10046   applypatch         path to external prg
10047   auto_commit        commit all changes to config variables to disk
10048   build_cache        size of cache for directories to build modules
10049   build_dir          locally accessible directory to build modules
10050   build_dir_reuse    boolean if distros in build_dir are persistent
10051   build_requires_install_policy
10052                      to install or not to install when a module is
10053                      only needed for building. yes|no|ask/yes|ask/no
10054   bzip2              path to external prg
10055   cache_metadata     use serializer to cache metadata
10056   commands_quote     prefered character to use for quoting external
10057                      commands when running them. Defaults to double
10058                      quote on Windows, single tick everywhere else;
10059                      can be set to space to disable quoting
10060   check_sigs         if signatures should be verified
10061   colorize_debug     Term::ANSIColor attributes for debugging output
10062   colorize_output    boolean if Term::ANSIColor should colorize output
10063   colorize_print     Term::ANSIColor attributes for normal output
10064   colorize_warn      Term::ANSIColor attributes for warnings
10065   commandnumber_in_prompt
10066                      boolean if you want to see current command number
10067   cpan_home          local directory reserved for this package
10068   curl               path to external prg
10069   dontload_hash      DEPRECATED
10070   dontload_list      arrayref: modules in the list will not be
10071                      loaded by the CPAN::has_inst() routine
10072   ftp                path to external prg
10073   ftp_passive        if set, the envariable FTP_PASSIVE is set for downloads
10074   ftp_proxy          proxy host for ftp requests
10075   getcwd             see below
10076   gpg                path to external prg
10077   gzip               location of external program gzip
10078   histfile           file to maintain history between sessions
10079   histsize           maximum number of lines to keep in histfile
10080   http_proxy         proxy host for http requests
10081   inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
10082                      after this many seconds inactivity. Set to 0 to
10083                      never break.
10084   index_expire       after this many days refetch index files
10085   inhibit_startup_message
10086                      if true, does not print the startup message
10087   keep_source_where  directory in which to keep the source (if we do)
10088   lynx               path to external prg
10089   make               location of external make program
10090   make_arg           arguments that should always be passed to 'make'
10091   make_install_make_command
10092                      the make command for running 'make install', for
10093                      example 'sudo make'
10094   make_install_arg   same as make_arg for 'make install'
10095   makepl_arg         arguments passed to 'perl Makefile.PL'
10096   mbuild_arg         arguments passed to './Build'
10097   mbuild_install_arg arguments passed to './Build install'
10098   mbuild_install_build_command
10099                      command to use instead of './Build' when we are
10100                      in the install stage, for example 'sudo ./Build'
10101   mbuildpl_arg       arguments passed to 'perl Build.PL'
10102   ncftp              path to external prg
10103   ncftpget           path to external prg
10104   no_proxy           don't proxy to these hosts/domains (comma separated list)
10105   pager              location of external program more (or any pager)
10106   password           your password if you CPAN server wants one
10107   patch              path to external prg
10108   prefer_installer   legal values are MB and EUMM: if a module comes
10109                      with both a Makefile.PL and a Build.PL, use the
10110                      former (EUMM) or the latter (MB); if the module
10111                      comes with only one of the two, that one will be
10112                      used in any case
10113   prerequisites_policy
10114                      what to do if you are missing module prerequisites
10115                      ('follow' automatically, 'ask' me, or 'ignore')
10116   prefs_dir          local directory to store per-distro build options
10117   proxy_user         username for accessing an authenticating proxy
10118   proxy_pass         password for accessing an authenticating proxy
10119   randomize_urllist  add some randomness to the sequence of the urllist
10120   scan_cache         controls scanning of cache ('atstart' or 'never')
10121   shell              your favorite shell
10122   show_upload_date   boolean if commands should try to determine upload date
10123   tar                location of external program tar
10124   term_is_latin      if true internal UTF-8 is translated to ISO-8859-1
10125                      (and nonsense for characters outside latin range)
10126   term_ornaments     boolean to turn ReadLine ornamenting on/off
10127   test_report        email test reports (if CPAN::Reporter is installed)
10128   unzip              location of external program unzip
10129   urllist            arrayref to nearby CPAN sites (or equivalent locations)
10130   use_sqlite         use CPAN::SQLite for metadata storage (fast and lean)
10131   username           your username if you CPAN server wants one
10132   wait_list          arrayref to a wait server to try (See CPAN::WAIT)
10133   wget               path to external prg
10134   yaml_module        which module to use to read/write YAML files
10135
10136 You can set and query each of these options interactively in the cpan
10137 shell with the C<o conf> or the C<o conf init> command as specified below.
10138
10139 =over 2
10140
10141 =item C<o conf E<lt>scalar optionE<gt>>
10142
10143 prints the current value of the I<scalar option>
10144
10145 =item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
10146
10147 Sets the value of the I<scalar option> to I<value>
10148
10149 =item C<o conf E<lt>list optionE<gt>>
10150
10151 prints the current value of the I<list option> in MakeMaker's
10152 neatvalue format.
10153
10154 =item C<o conf E<lt>list optionE<gt> [shift|pop]>
10155
10156 shifts or pops the array in the I<list option> variable
10157
10158 =item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
10159
10160 works like the corresponding perl commands.
10161
10162 =item interactive editing: o conf init [MATCH|LIST]
10163
10164 Runs an interactive configuration dialog for matching variables.
10165 Without argument runs the dialog over all supported config variables.
10166 To specify a MATCH the argument must be enclosed by slashes.
10167
10168 Examples:
10169
10170   o conf init ftp_passive ftp_proxy
10171   o conf init /color/
10172
10173 Note: this method of setting config variables often provides more
10174 explanation about the functioning of a variable than the manpage.
10175
10176 =back
10177
10178 =head2 CPAN::anycwd($path): Note on config variable getcwd
10179
10180 CPAN.pm changes the current working directory often and needs to
10181 determine its own current working directory. Per default it uses
10182 Cwd::cwd but if this doesn't work on your system for some reason,
10183 alternatives can be configured according to the following table:
10184
10185 =over 4
10186
10187 =item cwd
10188
10189 Calls Cwd::cwd
10190
10191 =item getcwd
10192
10193 Calls Cwd::getcwd
10194
10195 =item fastcwd
10196
10197 Calls Cwd::fastcwd
10198
10199 =item backtickcwd
10200
10201 Calls the external command cwd.
10202
10203 =back
10204
10205 =head2 Note on the format of the urllist parameter
10206
10207 urllist parameters are URLs according to RFC 1738. We do a little
10208 guessing if your URL is not compliant, but if you have problems with
10209 C<file> URLs, please try the correct format. Either:
10210
10211     file://localhost/whatever/ftp/pub/CPAN/
10212
10213 or
10214
10215     file:///home/ftp/pub/CPAN/
10216
10217 =head2 The urllist parameter has CD-ROM support
10218
10219 The C<urllist> parameter of the configuration table contains a list of
10220 URLs that are to be used for downloading. If the list contains any
10221 C<file> URLs, CPAN always tries to get files from there first. This
10222 feature is disabled for index files. So the recommendation for the
10223 owner of a CD-ROM with CPAN contents is: include your local, possibly
10224 outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
10225
10226   o conf urllist push file://localhost/CDROM/CPAN
10227
10228 CPAN.pm will then fetch the index files from one of the CPAN sites
10229 that come at the beginning of urllist. It will later check for each
10230 module if there is a local copy of the most recent version.
10231
10232 Another peculiarity of urllist is that the site that we could
10233 successfully fetch the last file from automatically gets a preference
10234 token and is tried as the first site for the next request. So if you
10235 add a new site at runtime it may happen that the previously preferred
10236 site will be tried another time. This means that if you want to disallow
10237 a site for the next transfer, it must be explicitly removed from
10238 urllist.
10239
10240 =head2 Maintaining the urllist parameter
10241
10242 If you have YAML.pm (or some other YAML module configured in
10243 C<yaml_module>) installed, CPAN.pm collects a few statistical data
10244 about recent downloads. You can view the statistics with the C<hosts>
10245 command or inspect them directly by looking into the C<FTPstats.yml>
10246 file in your C<cpan_home> directory.
10247
10248 To get some interesting statistics it is recommended to set the
10249 C<randomize_urllist> parameter that introduces some amount of
10250 randomness into the URL selection.
10251
10252 =head2 The C<requires> and C<build_requires> dependency declarations
10253
10254 Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
10255 a distribution are treated differently depending on the config
10256 variable C<build_requires_install_policy>. By setting
10257 C<build_requires_install_policy> to C<no> such a module is not being
10258 installed. It is only built and tested and then kept in the list of
10259 tested but uninstalled modules. As such it is available during the
10260 build of the dependent module by integrating the path to the
10261 C<blib/arch> and C<blib/lib> directories in the environment variable
10262 PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
10263 both modules declared as C<requires> and those declared as
10264 C<build_requires> are treated alike. By setting to C<ask/yes> or
10265 C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
10266
10267 =head2 Configuration for individual distributions (I<Distroprefs>)
10268
10269 (B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
10270 still considered beta quality)
10271
10272 Distributions on the CPAN usually behave according to what we call the
10273 CPAN mantra. Or since the event of Module::Build we should talk about
10274 two mantras:
10275
10276     perl Makefile.PL     perl Build.PL
10277     make                 ./Build
10278     make test            ./Build test
10279     make install         ./Build install
10280
10281 But some modules cannot be built with this mantra. They try to get
10282 some extra data from the user via the environment, extra arguments or
10283 interactively thus disturbing the installation of large bundles like
10284 Phalanx100 or modules with many dependencies like Plagger.
10285
10286 The distroprefs system of C<CPAN.pm> addresses this problem by
10287 allowing the user to specify extra informations and recipes in YAML
10288 files to either
10289
10290 =over
10291
10292 =item
10293
10294 pass additional arguments to one of the four commands,
10295
10296 =item
10297
10298 set environment variables
10299
10300 =item
10301
10302 instantiate an Expect object that reads from the console, waits for
10303 some regular expressions and enters some answers
10304
10305 =item
10306
10307 temporarily override assorted C<CPAN.pm> configuration variables
10308
10309 =item
10310
10311 disable the installation of an object altogether
10312
10313 =back
10314
10315 See the YAML and Data::Dumper files that come with the C<CPAN.pm>
10316 distribution in the C<distroprefs/> directory for examples.
10317
10318 =head2 Filenames
10319
10320 The YAML files themselves must have the C<.yml> extension, all other
10321 files are ignored (for two exceptions see I<Fallback Data::Dumper and
10322 Storable> below). The containing directory can be specified in
10323 C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
10324 prefs_dir> in the CPAN shell to set and activate the distroprefs
10325 system.
10326
10327 Every YAML file may contain arbitrary documents according to the YAML
10328 specification and every single document is treated as an entity that
10329 can specify the treatment of a single distribution.
10330
10331 The names of the files can be picked freely, C<CPAN.pm> always reads
10332 all files (in alphabetical order) and takes the key C<match> (see
10333 below in I<Language Specs>) as a hashref containing match criteria
10334 that determine if the current distribution matches the YAML document
10335 or not.
10336
10337 =head2 Fallback Data::Dumper and Storable
10338
10339 If neither your configured C<yaml_module> nor YAML.pm is installed
10340 CPAN.pm falls back to using Data::Dumper and Storable and looks for
10341 files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
10342 directory. These files are expected to contain one or more hashrefs.
10343 For Data::Dumper generated files, this is expected to be done with by
10344 defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
10345 with the command
10346
10347     ysh < somefile.yml > somefile.dd
10348
10349 For Storable files the rule is that they must be constructed such that
10350 C<Storable::retrieve(file)> returns an array reference and the array
10351 elements represent one distropref object each. The conversion from
10352 YAML would look like so:
10353
10354     perl -MYAML=LoadFile -MStorable=nstore -e '
10355         @y=LoadFile(shift);
10356         nstore(\@y, shift)' somefile.yml somefile.st
10357
10358 In bootstrapping situations it is usually sufficient to translate only
10359 a few YAML files to Data::Dumper for the crucial modules like
10360 C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
10361 over Data::Dumper, remember to pull out a Storable version that writes
10362 an older format than all the other Storable versions that will need to
10363 read them.
10364
10365 =head2 Blueprint
10366
10367 The following example contains all supported keywords and structures
10368 with the exception of C<eexpect> which can be used instead of
10369 C<expect>.
10370
10371   ---
10372   comment: "Demo"
10373   match:
10374     module: "Dancing::Queen"
10375     distribution: "^CHACHACHA/Dancing-"
10376     perl: "/usr/local/cariba-perl/bin/perl"
10377     perlconfig:
10378       archname: "freebsd"
10379   disabled: 1
10380   cpanconfig:
10381     make: gmake
10382   pl:
10383     args:
10384       - "--somearg=specialcase"
10385
10386     env: {}
10387
10388     expect:
10389       - "Which is your favorite fruit"
10390       - "apple\n"
10391
10392   make:
10393     args:
10394       - all
10395       - extra-all
10396
10397     env: {}
10398
10399     expect: []
10400
10401     commendline: "echo SKIPPING make"
10402
10403   test:
10404     args: []
10405
10406     env: {}
10407
10408     expect: []
10409
10410   install:
10411     args: []
10412
10413     env:
10414       WANT_TO_INSTALL: YES
10415
10416     expect:
10417       - "Do you really want to install"
10418       - "y\n"
10419
10420   patches:
10421     - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
10422
10423
10424 =head2 Language Specs
10425
10426 Every YAML document represents a single hash reference. The valid keys
10427 in this hash are as follows:
10428
10429 =over
10430
10431 =item comment [scalar]
10432
10433 A comment
10434
10435 =item cpanconfig [hash]
10436
10437 Temporarily override assorted C<CPAN.pm> configuration variables.
10438
10439 Supported are: C<build_requires_install_policy>, C<check_sigs>,
10440 C<make>, C<make_install_make_command>, C<prefer_installer>,
10441 C<test_report>. Please report as a bug when you need another one
10442 supported.
10443
10444 =item disabled [boolean]
10445
10446 Specifies that this distribution shall not be processed at all.
10447
10448 =item goto [string]
10449
10450 The canonical name of a delegate distribution that shall be installed
10451 instead. Useful when a new version, although it tests OK itself,
10452 breaks something else or a developer release or a fork is already
10453 uploaded that is better than the last released version.
10454
10455 =item install [hash]
10456
10457 Processing instructions for the C<make install> or C<./Build install>
10458 phase of the CPAN mantra. See below under I<Processiong Instructions>.
10459
10460 =item make [hash]
10461
10462 Processing instructions for the C<make> or C<./Build> phase of the
10463 CPAN mantra. See below under I<Processiong Instructions>.
10464
10465 =item match [hash]
10466
10467 A hashref with one or more of the keys C<distribution>, C<modules>,
10468 C<perl>, and C<perlconfig> that specify if a document is targeted at a
10469 specific CPAN distribution or installation.
10470
10471 The corresponding values are interpreted as regular expressions. The
10472 C<distribution> related one will be matched against the canonical
10473 distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
10474
10475 The C<module> related one will be matched against I<all> modules
10476 contained in the distribution until one module matches.
10477
10478 The C<perl> related one will be matched against C<$^X>.
10479
10480 The value associated with C<perlconfig> is itself a hashref that is
10481 matched against corresponding values in the C<%Config::Config> hash
10482 living in the C< Config.pm > module.
10483
10484 If more than one restriction of C<module>, C<distribution>, and
10485 C<perl> is specified, the results of the separately computed match
10486 values must all match. If this is the case then the hashref
10487 represented by the YAML document is returned as the preference
10488 structure for the current distribution.
10489
10490 =item patches [array]
10491
10492 An array of patches on CPAN or on the local disk to be applied in
10493 order via the external patch program. If the value for the C<-p>
10494 parameter is C<0> or C<1> is determined by reading the patch
10495 beforehand.
10496
10497 Note: if the C<applypatch> program is installed and C<CPAN::Config>
10498 knows about it B<and> a patch is written by the C<makepatch> program,
10499 then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
10500 and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
10501 distribution.
10502
10503 =item pl [hash]
10504
10505 Processing instructions for the C<perl Makefile.PL> or C<perl
10506 Build.PL> phase of the CPAN mantra. See below under I<Processiong
10507 Instructions>.
10508
10509 =item test [hash]
10510
10511 Processing instructions for the C<make test> or C<./Build test> phase
10512 of the CPAN mantra. See below under I<Processiong Instructions>.
10513
10514 =back
10515
10516 =head2 Processing Instructions
10517
10518 =over
10519
10520 =item args [array]
10521
10522 Arguments to be added to the command line
10523
10524 =item commandline
10525
10526 A full commandline that will be executed as it stands by a system
10527 call. During the execution the environment variable PERL will is set
10528 to $^X. If C<commandline> is specified, the content of C<args> is not
10529 used.
10530
10531 =item eexpect [hash]
10532
10533 Extended C<expect>. This is a hash reference with three allowed keys,
10534 C<mode>, C<timeout>, and C<talk>.
10535
10536 C<mode> may have the values C<deterministic> for the case where all
10537 questions come in the order written down and C<anyorder> for the case
10538 where the questions may come in any order. The default mode is
10539 C<deterministic>.
10540
10541 C<timeout> denotes a timeout in seconds. Floating point timeouts are
10542 OK. In the case of a C<mode=deterministic> the timeout denotes the
10543 timeout per question, in the case of C<mode=anyorder> it denotes the
10544 timeout per byte received from the stream or questions.
10545
10546 C<talk> is a reference to an array that contains alternating questions
10547 and answers. Questions are regular expressions and answers are literal
10548 strings. The Expect module will then watch the stream coming from the
10549 execution of the external program (C<perl Makefile.PL>, C<perl
10550 Build.PL>, C<make>, etc.).
10551
10552 In the case of C<mode=deterministic> the CPAN.pm will inject the
10553 according answer as soon as the stream matches the regular expression.
10554 In the case of C<mode=anyorder> the CPAN.pm will answer a question as
10555 soon as the timeout is reached for the next byte in the input stream.
10556 In the latter case it removes the according question/answer pair from
10557 the array, so if you want to answer the question C<Do you really want
10558 to do that> several times, then it must be included in the array at
10559 least as often as you want this answer to be given.
10560
10561 =item env [hash]
10562
10563 Environment variables to be set during the command
10564
10565 =item expect [array]
10566
10567 C<< expect: <array> >> is a short notation for
10568
10569   eexpect:
10570     mode: deterministic
10571     timeout: 15
10572     talk: <array>
10573
10574 =back
10575
10576 =head2 Schema verification with C<Kwalify>
10577
10578 If you have the C<Kwalify> module installed (which is part of the
10579 Bundle::CPANxxl), then all your distroprefs files are checked for
10580 syntactical correctness.
10581
10582 =head2 Example Distroprefs Files
10583
10584 C<CPAN.pm> comes with a collection of example YAML files. Note that these
10585 are really just examples and should not be used without care because
10586 they cannot fit everybody's purpose. After all the authors of the
10587 packages that ask questions had a need to ask, so you should watch
10588 their questions and adjust the examples to your environment and your
10589 needs. You have beend warned:-)
10590
10591 =head1 PROGRAMMER'S INTERFACE
10592
10593 If you do not enter the shell, the available shell commands are both
10594 available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
10595 functions in the calling package (C<install(...)>).  Before calling low-level
10596 commands it makes sense to initialize components of CPAN you need, e.g.:
10597
10598   CPAN::HandleConfig->load;
10599   CPAN::Shell::setup_output;
10600   CPAN::Index->reload;
10601
10602 High-level commands do such initializations automatically.
10603
10604 There's currently only one class that has a stable interface -
10605 CPAN::Shell. All commands that are available in the CPAN shell are
10606 methods of the class CPAN::Shell. Each of the commands that produce
10607 listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
10608 the IDs of all modules within the list.
10609
10610 =over 2
10611
10612 =item expand($type,@things)
10613
10614 The IDs of all objects available within a program are strings that can
10615 be expanded to the corresponding real objects with the
10616 C<CPAN::Shell-E<gt>expand("Module",@things)> method. Expand returns a
10617 list of CPAN::Module objects according to the C<@things> arguments
10618 given. In scalar context it only returns the first element of the
10619 list.
10620
10621 =item expandany(@things)
10622
10623 Like expand, but returns objects of the appropriate type, i.e.
10624 CPAN::Bundle objects for bundles, CPAN::Module objects for modules and
10625 CPAN::Distribution objects for distributions. Note: it does not expand
10626 to CPAN::Author objects.
10627
10628 =item Programming Examples
10629
10630 This enables the programmer to do operations that combine
10631 functionalities that are available in the shell.
10632
10633     # install everything that is outdated on my disk:
10634     perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
10635
10636     # install my favorite programs if necessary:
10637     for $mod (qw(Net::FTP Digest::SHA Data::Dumper)){
10638         CPAN::Shell->install($mod);
10639     }
10640
10641     # list all modules on my disk that have no VERSION number
10642     for $mod (CPAN::Shell->expand("Module","/./")){
10643         next unless $mod->inst_file;
10644         # MakeMaker convention for undefined $VERSION:
10645         next unless $mod->inst_version eq "undef";
10646         print "No VERSION in ", $mod->id, "\n";
10647     }
10648
10649     # find out which distribution on CPAN contains a module:
10650     print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
10651
10652 Or if you want to write a cronjob to watch The CPAN, you could list
10653 all modules that need updating. First a quick and dirty way:
10654
10655     perl -e 'use CPAN; CPAN::Shell->r;'
10656
10657 If you don't want to get any output in the case that all modules are
10658 up to date, you can parse the output of above command for the regular
10659 expression //modules are up to date// and decide to mail the output
10660 only if it doesn't match. Ick?
10661
10662 If you prefer to do it more in a programmer style in one single
10663 process, maybe something like this suits you better:
10664
10665   # list all modules on my disk that have newer versions on CPAN
10666   for $mod (CPAN::Shell->expand("Module","/./")){
10667     next unless $mod->inst_file;
10668     next if $mod->uptodate;
10669     printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
10670         $mod->id, $mod->inst_version, $mod->cpan_version;
10671   }
10672
10673 If that gives you too much output every day, you maybe only want to
10674 watch for three modules. You can write
10675
10676   for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")){
10677
10678 as the first line instead. Or you can combine some of the above
10679 tricks:
10680
10681   # watch only for a new mod_perl module
10682   $mod = CPAN::Shell->expand("Module","mod_perl");
10683   exit if $mod->uptodate;
10684   # new mod_perl arrived, let me know all update recommendations
10685   CPAN::Shell->r;
10686
10687 =back
10688
10689 =head2 Methods in the other Classes
10690
10691 =over 4
10692
10693 =item CPAN::Author::as_glimpse()
10694
10695 Returns a one-line description of the author
10696
10697 =item CPAN::Author::as_string()
10698
10699 Returns a multi-line description of the author
10700
10701 =item CPAN::Author::email()
10702
10703 Returns the author's email address
10704
10705 =item CPAN::Author::fullname()
10706
10707 Returns the author's name
10708
10709 =item CPAN::Author::name()
10710
10711 An alias for fullname
10712
10713 =item CPAN::Bundle::as_glimpse()
10714
10715 Returns a one-line description of the bundle
10716
10717 =item CPAN::Bundle::as_string()
10718
10719 Returns a multi-line description of the bundle
10720
10721 =item CPAN::Bundle::clean()
10722
10723 Recursively runs the C<clean> method on all items contained in the bundle.
10724
10725 =item CPAN::Bundle::contains()
10726
10727 Returns a list of objects' IDs contained in a bundle. The associated
10728 objects may be bundles, modules or distributions.
10729
10730 =item CPAN::Bundle::force($method,@args)
10731
10732 Forces CPAN to perform a task that it normally would have refused to
10733 do. Force takes as arguments a method name to be called and any number
10734 of additional arguments that should be passed to the called method.
10735 The internals of the object get the needed changes so that CPAN.pm
10736 does not refuse to take the action. The C<force> is passed recursively
10737 to all contained objects. See also the section above on the C<force>
10738 and the C<fforce> pragma.
10739
10740 =item CPAN::Bundle::get()
10741
10742 Recursively runs the C<get> method on all items contained in the bundle
10743
10744 =item CPAN::Bundle::inst_file()
10745
10746 Returns the highest installed version of the bundle in either @INC or
10747 C<$CPAN::Config->{cpan_home}>. Note that this is different from
10748 CPAN::Module::inst_file.
10749
10750 =item CPAN::Bundle::inst_version()
10751
10752 Like CPAN::Bundle::inst_file, but returns the $VERSION
10753
10754 =item CPAN::Bundle::uptodate()
10755
10756 Returns 1 if the bundle itself and all its members are uptodate.
10757
10758 =item CPAN::Bundle::install()
10759
10760 Recursively runs the C<install> method on all items contained in the bundle
10761
10762 =item CPAN::Bundle::make()
10763
10764 Recursively runs the C<make> method on all items contained in the bundle
10765
10766 =item CPAN::Bundle::readme()
10767
10768 Recursively runs the C<readme> method on all items contained in the bundle
10769
10770 =item CPAN::Bundle::test()
10771
10772 Recursively runs the C<test> method on all items contained in the bundle
10773
10774 =item CPAN::Distribution::as_glimpse()
10775
10776 Returns a one-line description of the distribution
10777
10778 =item CPAN::Distribution::as_string()
10779
10780 Returns a multi-line description of the distribution
10781
10782 =item CPAN::Distribution::author
10783
10784 Returns the CPAN::Author object of the maintainer who uploaded this
10785 distribution
10786
10787 =item CPAN::Distribution::clean()
10788
10789 Changes to the directory where the distribution has been unpacked and
10790 runs C<make clean> there.
10791
10792 =item CPAN::Distribution::containsmods()
10793
10794 Returns a list of IDs of modules contained in a distribution file.
10795 Only works for distributions listed in the 02packages.details.txt.gz
10796 file. This typically means that only the most recent version of a
10797 distribution is covered.
10798
10799 =item CPAN::Distribution::cvs_import()
10800
10801 Changes to the directory where the distribution has been unpacked and
10802 runs something like
10803
10804     cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
10805
10806 there.
10807
10808 =item CPAN::Distribution::dir()
10809
10810 Returns the directory into which this distribution has been unpacked.
10811
10812 =item CPAN::Distribution::force($method,@args)
10813
10814 Forces CPAN to perform a task that it normally would have refused to
10815 do. Force takes as arguments a method name to be called and any number
10816 of additional arguments that should be passed to the called method.
10817 The internals of the object get the needed changes so that CPAN.pm
10818 does not refuse to take the action. See also the section above on the
10819 C<force> and the C<fforce> pragma.
10820
10821 =item CPAN::Distribution::get()
10822
10823 Downloads the distribution from CPAN and unpacks it. Does nothing if
10824 the distribution has already been downloaded and unpacked within the
10825 current session.
10826
10827 =item CPAN::Distribution::install()
10828
10829 Changes to the directory where the distribution has been unpacked and
10830 runs the external command C<make install> there. If C<make> has not
10831 yet been run, it will be run first. A C<make test> will be issued in
10832 any case and if this fails, the install will be canceled. The
10833 cancellation can be avoided by letting C<force> run the C<install> for
10834 you.
10835
10836 This install method has only the power to install the distribution if
10837 there are no dependencies in the way. To install an object and all of
10838 its dependencies, use CPAN::Shell->install.
10839
10840 Note that install() gives no meaningful return value. See uptodate().
10841
10842 =item CPAN::Distribution::install_tested()
10843
10844 Install all the distributions that have been tested sucessfully but
10845 not yet installed. See also C<is_tested>.
10846
10847 =item CPAN::Distribution::isa_perl()
10848
10849 Returns 1 if this distribution file seems to be a perl distribution.
10850 Normally this is derived from the file name only, but the index from
10851 CPAN can contain a hint to achieve a return value of true for other
10852 filenames too.
10853
10854 =item CPAN::Distribution::is_tested()
10855
10856 List all the distributions that have been tested sucessfully but not
10857 yet installed. See also C<install_tested>.
10858
10859 =item CPAN::Distribution::look()
10860
10861 Changes to the directory where the distribution has been unpacked and
10862 opens a subshell there. Exiting the subshell returns.
10863
10864 =item CPAN::Distribution::make()
10865
10866 First runs the C<get> method to make sure the distribution is
10867 downloaded and unpacked. Changes to the directory where the
10868 distribution has been unpacked and runs the external commands C<perl
10869 Makefile.PL> or C<perl Build.PL> and C<make> there.
10870
10871 =item CPAN::Distribution::perldoc()
10872
10873 Downloads the pod documentation of the file associated with a
10874 distribution (in html format) and runs it through the external
10875 command lynx specified in C<$CPAN::Config->{lynx}>. If lynx
10876 isn't available, it converts it to plain text with external
10877 command html2text and runs it through the pager specified
10878 in C<$CPAN::Config->{pager}>
10879
10880 =item CPAN::Distribution::prefs()
10881
10882 Returns the hash reference from the first matching YAML file that the
10883 user has deposited in the C<prefs_dir/> directory. The first
10884 succeeding match wins. The files in the C<prefs_dir/> are processed
10885 alphabetically and the canonical distroname (e.g.
10886 AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
10887 stored in the $root->{match}{distribution} attribute value.
10888 Additionally all module names contained in a distribution are matched
10889 agains the regular expressions in the $root->{match}{module} attribute
10890 value. The two match values are ANDed together. Each of the two
10891 attributes are optional.
10892
10893 =item CPAN::Distribution::prereq_pm()
10894
10895 Returns the hash reference that has been announced by a distribution
10896 as the the C<requires> and C<build_requires> elements. These can be
10897 declared either by the C<META.yml> (if authoritative) or can be
10898 deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
10899 or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
10900 a comment in the produced C<Makefile>. I<Note>: this method only works
10901 after an attempt has been made to C<make> the distribution. Returns
10902 undef otherwise.
10903
10904 =item CPAN::Distribution::readme()
10905
10906 Downloads the README file associated with a distribution and runs it
10907 through the pager specified in C<$CPAN::Config->{pager}>.
10908
10909 =item CPAN::Distribution::read_yaml()
10910
10911 Returns the content of the META.yml of this distro as a hashref. Note:
10912 works only after an attempt has been made to C<make> the distribution.
10913 Returns undef otherwise. Also returns undef if the content of META.yml
10914 is not authoritative. (The rules about what exactly makes the content
10915 authoritative are still in flux.)
10916
10917 =item CPAN::Distribution::test()
10918
10919 Changes to the directory where the distribution has been unpacked and
10920 runs C<make test> there.
10921
10922 =item CPAN::Distribution::uptodate()
10923
10924 Returns 1 if all the modules contained in the distribution are
10925 uptodate. Relies on containsmods.
10926
10927 =item CPAN::Index::force_reload()
10928
10929 Forces a reload of all indices.
10930
10931 =item CPAN::Index::reload()
10932
10933 Reloads all indices if they have not been read for more than
10934 C<$CPAN::Config->{index_expire}> days.
10935
10936 =item CPAN::InfoObj::dump()
10937
10938 CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
10939 inherit this method. It prints the data structure associated with an
10940 object. Useful for debugging. Note: the data structure is considered
10941 internal and thus subject to change without notice.
10942
10943 =item CPAN::Module::as_glimpse()
10944
10945 Returns a one-line description of the module in four columns: The
10946 first column contains the word C<Module>, the second column consists
10947 of one character: an equals sign if this module is already installed
10948 and uptodate, a less-than sign if this module is installed but can be
10949 upgraded, and a space if the module is not installed. The third column
10950 is the name of the module and the fourth column gives maintainer or
10951 distribution information.
10952
10953 =item CPAN::Module::as_string()
10954
10955 Returns a multi-line description of the module
10956
10957 =item CPAN::Module::clean()
10958
10959 Runs a clean on the distribution associated with this module.
10960
10961 =item CPAN::Module::cpan_file()
10962
10963 Returns the filename on CPAN that is associated with the module.
10964
10965 =item CPAN::Module::cpan_version()
10966
10967 Returns the latest version of this module available on CPAN.
10968
10969 =item CPAN::Module::cvs_import()
10970
10971 Runs a cvs_import on the distribution associated with this module.
10972
10973 =item CPAN::Module::description()
10974
10975 Returns a 44 character description of this module. Only available for
10976 modules listed in The Module List (CPAN/modules/00modlist.long.html
10977 or 00modlist.long.txt.gz)
10978
10979 =item CPAN::Module::distribution()
10980
10981 Returns the CPAN::Distribution object that contains the current
10982 version of this module.
10983
10984 =item CPAN::Module::dslip_status()
10985
10986 Returns a hash reference. The keys of the hash are the letters C<D>,
10987 C<S>, C<L>, C<I>, and <P>, for development status, support level,
10988 language, interface and public licence respectively. The data for the
10989 DSLIP status are collected by pause.perl.org when authors register
10990 their namespaces. The values of the 5 hash elements are one-character
10991 words whose meaning is described in the table below. There are also 5
10992 hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
10993 verbose value of the 5 status variables.
10994
10995 Where the 'DSLIP' characters have the following meanings:
10996
10997   D - Development Stage  (Note: *NO IMPLIED TIMESCALES*):
10998     i   - Idea, listed to gain consensus or as a placeholder
10999     c   - under construction but pre-alpha (not yet released)
11000     a/b - Alpha/Beta testing
11001     R   - Released
11002     M   - Mature (no rigorous definition)
11003     S   - Standard, supplied with Perl 5
11004
11005   S - Support Level:
11006     m   - Mailing-list
11007     d   - Developer
11008     u   - Usenet newsgroup comp.lang.perl.modules
11009     n   - None known, try comp.lang.perl.modules
11010     a   - abandoned; volunteers welcome to take over maintainance
11011
11012   L - Language Used:
11013     p   - Perl-only, no compiler needed, should be platform independent
11014     c   - C and perl, a C compiler will be needed
11015     h   - Hybrid, written in perl with optional C code, no compiler needed
11016     +   - C++ and perl, a C++ compiler will be needed
11017     o   - perl and another language other than C or C++
11018
11019   I - Interface Style
11020     f   - plain Functions, no references used
11021     h   - hybrid, object and function interfaces available
11022     n   - no interface at all (huh?)
11023     r   - some use of unblessed References or ties
11024     O   - Object oriented using blessed references and/or inheritance
11025
11026   P - Public License
11027     p   - Standard-Perl: user may choose between GPL and Artistic
11028     g   - GPL: GNU General Public License
11029     l   - LGPL: "GNU Lesser General Public License" (previously known as
11030           "GNU Library General Public License")
11031     b   - BSD: The BSD License
11032     a   - Artistic license alone
11033     o   - open source: appoved by www.opensource.org
11034     d   - allows distribution without restrictions
11035     r   - restricted distribtion
11036     n   - no license at all
11037
11038 =item CPAN::Module::force($method,@args)
11039
11040 Forces CPAN to perform a task that it normally would have refused to
11041 do. Force takes as arguments a method name to be called and any number
11042 of additional arguments that should be passed to the called method.
11043 The internals of the object get the needed changes so that CPAN.pm
11044 does not refuse to take the action. See also the section above on the
11045 C<force> and the C<fforce> pragma.
11046
11047 =item CPAN::Module::get()
11048
11049 Runs a get on the distribution associated with this module.
11050
11051 =item CPAN::Module::inst_file()
11052
11053 Returns the filename of the module found in @INC. The first file found
11054 is reported just like perl itself stops searching @INC when it finds a
11055 module.
11056
11057 =item CPAN::Module::available_file()
11058
11059 Returns the filename of the module found in PERL5LIB or @INC. The
11060 first file found is reported. The advantage of this method over
11061 C<inst_file> is that modules that have been tested but not yet
11062 installed are included because PERL5LIB keeps track of tested modules.
11063
11064 =item CPAN::Module::inst_version()
11065
11066 Returns the version number of the installed module in readable format.
11067
11068 =item CPAN::Module::available_version()
11069
11070 Returns the version number of the available module in readable format.
11071
11072 =item CPAN::Module::install()
11073
11074 Runs an C<install> on the distribution associated with this module.
11075
11076 =item CPAN::Module::look()
11077
11078 Changes to the directory where the distribution associated with this
11079 module has been unpacked and opens a subshell there. Exiting the
11080 subshell returns.
11081
11082 =item CPAN::Module::make()
11083
11084 Runs a C<make> on the distribution associated with this module.
11085
11086 =item CPAN::Module::manpage_headline()
11087
11088 If module is installed, peeks into the module's manpage, reads the
11089 headline and returns it. Moreover, if the module has been downloaded
11090 within this session, does the equivalent on the downloaded module even
11091 if it is not installed.
11092
11093 =item CPAN::Module::perldoc()
11094
11095 Runs a C<perldoc> on this module.
11096
11097 =item CPAN::Module::readme()
11098
11099 Runs a C<readme> on the distribution associated with this module.
11100
11101 =item CPAN::Module::test()
11102
11103 Runs a C<test> on the distribution associated with this module.
11104
11105 =item CPAN::Module::uptodate()
11106
11107 Returns 1 if the module is installed and up-to-date.
11108
11109 =item CPAN::Module::userid()
11110
11111 Returns the author's ID of the module.
11112
11113 =back
11114
11115 =head2 Cache Manager
11116
11117 Currently the cache manager only keeps track of the build directory
11118 ($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
11119 deletes complete directories below C<build_dir> as soon as the size of
11120 all directories there gets bigger than $CPAN::Config->{build_cache}
11121 (in MB). The contents of this cache may be used for later
11122 re-installations that you intend to do manually, but will never be
11123 trusted by CPAN itself. This is due to the fact that the user might
11124 use these directories for building modules on different architectures.
11125
11126 There is another directory ($CPAN::Config->{keep_source_where}) where
11127 the original distribution files are kept. This directory is not
11128 covered by the cache manager and must be controlled by the user. If
11129 you choose to have the same directory as build_dir and as
11130 keep_source_where directory, then your sources will be deleted with
11131 the same fifo mechanism.
11132
11133 =head2 Bundles
11134
11135 A bundle is just a perl module in the namespace Bundle:: that does not
11136 define any functions or methods. It usually only contains documentation.
11137
11138 It starts like a perl module with a package declaration and a $VERSION
11139 variable. After that the pod section looks like any other pod with the
11140 only difference being that I<one special pod section> exists starting with
11141 (verbatim):
11142
11143         =head1 CONTENTS
11144
11145 In this pod section each line obeys the format
11146
11147         Module_Name [Version_String] [- optional text]
11148
11149 The only required part is the first field, the name of a module
11150 (e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
11151 of the line is optional. The comment part is delimited by a dash just
11152 as in the man page header.
11153
11154 The distribution of a bundle should follow the same convention as
11155 other distributions.
11156
11157 Bundles are treated specially in the CPAN package. If you say 'install
11158 Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
11159 the modules in the CONTENTS section of the pod. You can install your
11160 own Bundles locally by placing a conformant Bundle file somewhere into
11161 your @INC path. The autobundle() command which is available in the
11162 shell interface does that for you by including all currently installed
11163 modules in a snapshot bundle file.
11164
11165 =head1 PREREQUISITES
11166
11167 If you have a local mirror of CPAN and can access all files with
11168 "file:" URLs, then you only need a perl better than perl5.003 to run
11169 this module. Otherwise Net::FTP is strongly recommended. LWP may be
11170 required for non-UNIX systems or if your nearest CPAN site is
11171 associated with a URL that is not C<ftp:>.
11172
11173 If you have neither Net::FTP nor LWP, there is a fallback mechanism
11174 implemented for an external ftp command or for an external lynx
11175 command.
11176
11177 =head1 UTILITIES
11178
11179 =head2 Finding packages and VERSION
11180
11181 This module presumes that all packages on CPAN
11182
11183 =over 2
11184
11185 =item *
11186
11187 declare their $VERSION variable in an easy to parse manner. This
11188 prerequisite can hardly be relaxed because it consumes far too much
11189 memory to load all packages into the running program just to determine
11190 the $VERSION variable. Currently all programs that are dealing with
11191 version use something like this
11192
11193     perl -MExtUtils::MakeMaker -le \
11194         'print MM->parse_version(shift)' filename
11195
11196 If you are author of a package and wonder if your $VERSION can be
11197 parsed, please try the above method.
11198
11199 =item *
11200
11201 come as compressed or gzipped tarfiles or as zip files and contain a
11202 C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
11203 without much enthusiasm).
11204
11205 =back
11206
11207 =head2 Debugging
11208
11209 The debugging of this module is a bit complex, because we have
11210 interferences of the software producing the indices on CPAN, of the
11211 mirroring process on CPAN, of packaging, of configuration, of
11212 synchronicity, and of bugs within CPAN.pm.
11213
11214 For debugging the code of CPAN.pm itself in interactive mode some more
11215 or less useful debugging aid can be turned on for most packages within
11216 CPAN.pm with one of
11217
11218 =over 2
11219
11220 =item o debug package...
11221
11222 sets debug mode for packages.
11223
11224 =item o debug -package...
11225
11226 unsets debug mode for packages.
11227
11228 =item o debug all
11229
11230 turns debugging on for all packages.
11231
11232 =item o debug number
11233
11234 =back
11235
11236 which sets the debugging packages directly. Note that C<o debug 0>
11237 turns debugging off.
11238
11239 What seems quite a successful strategy is the combination of C<reload
11240 cpan> and the debugging switches. Add a new debug statement while
11241 running in the shell and then issue a C<reload cpan> and see the new
11242 debugging messages immediately without losing the current context.
11243
11244 C<o debug> without an argument lists the valid package names and the
11245 current set of packages in debugging mode. C<o debug> has built-in
11246 completion support.
11247
11248 For debugging of CPAN data there is the C<dump> command which takes
11249 the same arguments as make/test/install and outputs each object's
11250 Data::Dumper dump. If an argument looks like a perl variable and
11251 contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
11252 Data::Dumper directly.
11253
11254 =head2 Floppy, Zip, Offline Mode
11255
11256 CPAN.pm works nicely without network too. If you maintain machines
11257 that are not networked at all, you should consider working with file:
11258 URLs. Of course, you have to collect your modules somewhere first. So
11259 you might use CPAN.pm to put together all you need on a networked
11260 machine. Then copy the $CPAN::Config->{keep_source_where} (but not
11261 $CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
11262 of a personal CPAN. CPAN.pm on the non-networked machines works nicely
11263 with this floppy. See also below the paragraph about CD-ROM support.
11264
11265 =head2 Basic Utilities for Programmers
11266
11267 =over 2
11268
11269 =item has_inst($module)
11270
11271 Returns true if the module is installed. Used to load all modules into
11272 the running CPAN.pm which are considered optional. The config variable
11273 C<dontload_list> can be used to intercept the C<has_inst()> call such
11274 that an optional module is not loaded despite being available. For
11275 example the following command will prevent that C<YAML.pm> is being
11276 loaded:
11277
11278     cpan> o conf dontload_list push YAML
11279
11280 See the source for details.
11281
11282 =item has_usable($module)
11283
11284 Returns true if the module is installed and is in a usable state. Only
11285 useful for a handful of modules that are used internally. See the
11286 source for details.
11287
11288 =item instance($module)
11289
11290 The constructor for all the singletons used to represent modules,
11291 distributions, authors and bundles. If the object already exists, this
11292 method returns the object, otherwise it calls the constructor.
11293
11294 =back
11295
11296 =head1 SECURITY
11297
11298 There's no strong security layer in CPAN.pm. CPAN.pm helps you to
11299 install foreign, unmasked, unsigned code on your machine. We compare
11300 to a checksum that comes from the net just as the distribution file
11301 itself. But we try to make it easy to add security on demand:
11302
11303 =head2 Cryptographically signed modules
11304
11305 Since release 1.77 CPAN.pm has been able to verify cryptographically
11306 signed module distributions using Module::Signature.  The CPAN modules
11307 can be signed by their authors, thus giving more security.  The simple
11308 unsigned MD5 checksums that were used before by CPAN protect mainly
11309 against accidental file corruption.
11310
11311 You will need to have Module::Signature installed, which in turn
11312 requires that you have at least one of Crypt::OpenPGP module or the
11313 command-line F<gpg> tool installed.
11314
11315 You will also need to be able to connect over the Internet to the public
11316 keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
11317
11318 The configuration parameter check_sigs is there to turn signature
11319 checking on or off.
11320
11321 =head1 EXPORT
11322
11323 Most functions in package CPAN are exported per default. The reason
11324 for this is that the primary use is intended for the cpan shell or for
11325 one-liners.
11326
11327 =head1 ENVIRONMENT
11328
11329 When the CPAN shell enters a subshell via the look command, it sets
11330 the environment CPAN_SHELL_LEVEL to 1 or increments it if it is
11331 already set.
11332
11333 When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING.
11334
11335 When the config variable ftp_passive is set, all downloads will be run
11336 with the environment variable FTP_PASSIVE set to this value. This is
11337 in general a good idea as it influences both Net::FTP and LWP based
11338 connections. The same effect can be achieved by starting the cpan
11339 shell with this environment variable set. For Net::FTP alone, one can
11340 also always set passive mode by running libnetcfg.
11341
11342 =head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
11343
11344 Populating a freshly installed perl with my favorite modules is pretty
11345 easy if you maintain a private bundle definition file. To get a useful
11346 blueprint of a bundle definition file, the command autobundle can be used
11347 on the CPAN shell command line. This command writes a bundle definition
11348 file for all modules that are installed for the currently running perl
11349 interpreter. It's recommended to run this command only once and from then
11350 on maintain the file manually under a private name, say
11351 Bundle/my_bundle.pm. With a clever bundle file you can then simply say
11352
11353     cpan> install Bundle::my_bundle
11354
11355 then answer a few questions and then go out for a coffee.
11356
11357 Maintaining a bundle definition file means keeping track of two
11358 things: dependencies and interactivity. CPAN.pm sometimes fails on
11359 calculating dependencies because not all modules define all MakeMaker
11360 attributes correctly, so a bundle definition file should specify
11361 prerequisites as early as possible. On the other hand, it's a bit
11362 annoying that many distributions need some interactive configuring. So
11363 what I try to accomplish in my private bundle file is to have the
11364 packages that need to be configured early in the file and the gentle
11365 ones later, so I can go out after a few minutes and leave CPAN.pm
11366 untended.
11367
11368 =head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
11369
11370 Thanks to Graham Barr for contributing the following paragraphs about
11371 the interaction between perl, and various firewall configurations. For
11372 further information on firewalls, it is recommended to consult the
11373 documentation that comes with the ncftp program. If you are unable to
11374 go through the firewall with a simple Perl setup, it is very likely
11375 that you can configure ncftp so that it works for your firewall.
11376
11377 =head2 Three basic types of firewalls
11378
11379 Firewalls can be categorized into three basic types.
11380
11381 =over 4
11382
11383 =item http firewall
11384
11385 This is where the firewall machine runs a web server and to access the
11386 outside world you must do it via the web server. If you set environment
11387 variables like http_proxy or ftp_proxy to a values beginning with http://
11388 or in your web browser you have to set proxy information then you know
11389 you are running an http firewall.
11390
11391 To access servers outside these types of firewalls with perl (even for
11392 ftp) you will need to use LWP.
11393
11394 =item ftp firewall
11395
11396 This where the firewall machine runs an ftp server. This kind of
11397 firewall will only let you access ftp servers outside the firewall.
11398 This is usually done by connecting to the firewall with ftp, then
11399 entering a username like "user@outside.host.com"
11400
11401 To access servers outside these type of firewalls with perl you
11402 will need to use Net::FTP.
11403
11404 =item One way visibility
11405
11406 I say one way visibility as these firewalls try to make themselves look
11407 invisible to the users inside the firewall. An FTP data connection is
11408 normally created by sending the remote server your IP address and then
11409 listening for the connection. But the remote server will not be able to
11410 connect to you because of the firewall. So for these types of firewall
11411 FTP connections need to be done in a passive mode.
11412
11413 There are two that I can think off.
11414
11415 =over 4
11416
11417 =item SOCKS
11418
11419 If you are using a SOCKS firewall you will need to compile perl and link
11420 it with the SOCKS library, this is what is normally called a 'socksified'
11421 perl. With this executable you will be able to connect to servers outside
11422 the firewall as if it is not there.
11423
11424 =item IP Masquerade
11425
11426 This is the firewall implemented in the Linux kernel, it allows you to
11427 hide a complete network behind one IP address. With this firewall no
11428 special compiling is needed as you can access hosts directly.
11429
11430 For accessing ftp servers behind such firewalls you usually need to
11431 set the environment variable C<FTP_PASSIVE> or the config variable
11432 ftp_passive to a true value.
11433
11434 =back
11435
11436 =back
11437
11438 =head2 Configuring lynx or ncftp for going through a firewall
11439
11440 If you can go through your firewall with e.g. lynx, presumably with a
11441 command such as
11442
11443     /usr/local/bin/lynx -pscott:tiger
11444
11445 then you would configure CPAN.pm with the command
11446
11447     o conf lynx "/usr/local/bin/lynx -pscott:tiger"
11448
11449 That's all. Similarly for ncftp or ftp, you would configure something
11450 like
11451
11452     o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
11453
11454 Your mileage may vary...
11455
11456 =head1 FAQ
11457
11458 =over 4
11459
11460 =item 1)
11461
11462 I installed a new version of module X but CPAN keeps saying,
11463 I have the old version installed
11464
11465 Most probably you B<do> have the old version installed. This can
11466 happen if a module installs itself into a different directory in the
11467 @INC path than it was previously installed. This is not really a
11468 CPAN.pm problem, you would have the same problem when installing the
11469 module manually. The easiest way to prevent this behaviour is to add
11470 the argument C<UNINST=1> to the C<make install> call, and that is why
11471 many people add this argument permanently by configuring
11472
11473   o conf make_install_arg UNINST=1
11474
11475 =item 2)
11476
11477 So why is UNINST=1 not the default?
11478
11479 Because there are people who have their precise expectations about who
11480 may install where in the @INC path and who uses which @INC array. In
11481 fine tuned environments C<UNINST=1> can cause damage.
11482
11483 =item 3)
11484
11485 I want to clean up my mess, and install a new perl along with
11486 all modules I have. How do I go about it?
11487
11488 Run the autobundle command for your old perl and optionally rename the
11489 resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
11490 with the Configure option prefix, e.g.
11491
11492     ./Configure -Dprefix=/usr/local/perl-5.6.78.9
11493
11494 Install the bundle file you produced in the first step with something like
11495
11496     cpan> install Bundle::mybundle
11497
11498 and you're done.
11499
11500 =item 4)
11501
11502 When I install bundles or multiple modules with one command
11503 there is too much output to keep track of.
11504
11505 You may want to configure something like
11506
11507   o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
11508   o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
11509
11510 so that STDOUT is captured in a file for later inspection.
11511
11512
11513 =item 5)
11514
11515 I am not root, how can I install a module in a personal directory?
11516
11517 First of all, you will want to use your own configuration, not the one
11518 that your root user installed. If you do not have permission to write
11519 in the cpan directory that root has configured, you will be asked if
11520 you want to create your own config. Answering "yes" will bring you into
11521 CPAN's configuration stage, using the system config for all defaults except
11522 things that have to do with CPAN's work directory, saving your choices to
11523 your MyConfig.pm file.
11524
11525 You can also manually initiate this process with the following command:
11526
11527     % perl -MCPAN -e 'mkmyconfig'
11528
11529 or by running
11530
11531     mkmyconfig
11532
11533 from the CPAN shell.
11534
11535 You will most probably also want to configure something like this:
11536
11537   o conf makepl_arg "LIB=~/myperl/lib \
11538                     INSTALLMAN1DIR=~/myperl/man/man1 \
11539                     INSTALLMAN3DIR=~/myperl/man/man3 \
11540                     INSTALLSCRIPT=~/myperl/bin \
11541                     INSTALLBIN=~/myperl/bin"
11542
11543 and then (oh joy) the equivalent command for Module::Build.
11544
11545 You can make this setting permanent like all C<o conf> settings with
11546 C<o conf commit> or by setting C<auto_commit> beforehand.
11547
11548 You will have to add ~/myperl/man to the MANPATH environment variable
11549 and also tell your perl programs to look into ~/myperl/lib, e.g. by
11550 including
11551
11552   use lib "$ENV{HOME}/myperl/lib";
11553
11554 or setting the PERL5LIB environment variable.
11555
11556 While we're speaking about $ENV{HOME}, it might be worth mentioning,
11557 that for Windows we use the File::HomeDir module that provides an
11558 equivalent to the concept of the home directory on Unix.
11559
11560 Another thing you should bear in mind is that the UNINST parameter can
11561 be dnagerous when you are installing into a private area because you
11562 might accidentally remove modules that other people depend on that are
11563 not using the private area.
11564
11565 =item 6)
11566
11567 How to get a package, unwrap it, and make a change before building it?
11568
11569 Have a look at the C<look> (!) command.
11570
11571 =item 7)
11572
11573 I installed a Bundle and had a couple of fails. When I
11574 retried, everything resolved nicely. Can this be fixed to work
11575 on first try?
11576
11577 The reason for this is that CPAN does not know the dependencies of all
11578 modules when it starts out. To decide about the additional items to
11579 install, it just uses data found in the META.yml file or the generated
11580 Makefile. An undetected missing piece breaks the process. But it may
11581 well be that your Bundle installs some prerequisite later than some
11582 depending item and thus your second try is able to resolve everything.
11583 Please note, CPAN.pm does not know the dependency tree in advance and
11584 cannot sort the queue of things to install in a topologically correct
11585 order. It resolves perfectly well IF all modules declare the
11586 prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
11587 the C<requires> stanza of Module::Build. For bundles which fail and
11588 you need to install often, it is recommended to sort the Bundle
11589 definition file manually.
11590
11591 =item 8)
11592
11593 In our intranet we have many modules for internal use. How
11594 can I integrate these modules with CPAN.pm but without uploading
11595 the modules to CPAN?
11596
11597 Have a look at the CPAN::Site module.
11598
11599 =item 9)
11600
11601 When I run CPAN's shell, I get an error message about things in my
11602 /etc/inputrc (or ~/.inputrc) file.
11603
11604 These are readline issues and can only be fixed by studying readline
11605 configuration on your architecture and adjusting the referenced file
11606 accordingly. Please make a backup of the /etc/inputrc or ~/.inputrc
11607 and edit them. Quite often harmless changes like uppercasing or
11608 lowercasing some arguments solves the problem.
11609
11610 =item 10)
11611
11612 Some authors have strange characters in their names.
11613
11614 Internally CPAN.pm uses the UTF-8 charset. If your terminal is
11615 expecting ISO-8859-1 charset, a converter can be activated by setting
11616 term_is_latin to a true value in your config file. One way of doing so
11617 would be
11618
11619     cpan> o conf term_is_latin 1
11620
11621 If other charset support is needed, please file a bugreport against
11622 CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
11623 the support or maybe UTF-8 terminals become widely available.
11624
11625 =item 11)
11626
11627 When an install fails for some reason and then I correct the error
11628 condition and retry, CPAN.pm refuses to install the module, saying
11629 C<Already tried without success>.
11630
11631 Use the force pragma like so
11632
11633   force install Foo::Bar
11634
11635 Or you can use
11636
11637   look Foo::Bar
11638
11639 and then 'make install' directly in the subshell.
11640
11641 =item 12)
11642
11643 How do I install a "DEVELOPER RELEASE" of a module?
11644
11645 By default, CPAN will install the latest non-developer release of a
11646 module. If you want to install a dev release, you have to specify the
11647 partial path starting with the author id to the tarball you wish to
11648 install, like so:
11649
11650     cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
11651
11652 Note that you can use the C<ls> command to get this path listed.
11653
11654 =item 13)
11655
11656 How do I install a module and all its dependencies from the commandline,
11657 without being prompted for anything, despite my CPAN configuration
11658 (or lack thereof)?
11659
11660 CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
11661 if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
11662 asked any questions at all (assuming the modules you are installing are
11663 nice about obeying that variable as well):
11664
11665     % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
11666
11667 =item 14)
11668
11669 How do I create a Module::Build based Build.PL derived from an
11670 ExtUtils::MakeMaker focused Makefile.PL?
11671
11672 http://search.cpan.org/search?query=Module::Build::Convert
11673
11674 http://www.refcnt.org/papers/module-build-convert
11675
11676 =item 15)
11677
11678 What's the best CPAN site for me?
11679
11680 The urllist config parameter is yours. You can add and remove sites at
11681 will. You should find out which sites have the best uptodateness,
11682 bandwidth, reliability, etc. and are topologically close to you. Some
11683 people prefer fast downloads, others uptodateness, others reliability.
11684 You decide which to try in which order.
11685
11686 Henk P. Penning maintains a site that collects data about CPAN sites:
11687
11688   http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
11689
11690 =back
11691
11692 =head1 COMPATIBILITY
11693
11694 =head2 OLD PERL VERSIONS
11695
11696 CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
11697 newer versions. It is getting more and more difficult to get the
11698 minimal prerequisites working on older perls. It is close to
11699 impossible to get the whole Bundle::CPAN working there. If you're in
11700 the position to have only these old versions, be advised that CPAN is
11701 designed to work fine without the Bundle::CPAN installed.
11702
11703 To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
11704 compatible with ancient perls and that File::Temp is listed as a
11705 prerequisite but CPAN has reasonable workarounds if it is missing.
11706
11707 =head2 CPANPLUS
11708
11709 This module and its competitor, the CPANPLUS module, are both much
11710 cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
11711 more modular but it was never tried to make it compatible with CPAN.pm.
11712
11713 =head1 SECURITY ADVICE
11714
11715 This software enables you to upgrade software on your computer and so
11716 is inherently dangerous because the newly installed software may
11717 contain bugs and may alter the way your computer works or even make it
11718 unusable. Please consider backing up your data before every upgrade.
11719
11720 =head1 BUGS
11721
11722 Please report bugs via http://rt.cpan.org/
11723
11724 Before submitting a bug, please make sure that the traditional method
11725 of building a Perl module package from a shell by following the
11726 installation instructions of that package still works in your
11727 environment.
11728
11729 =head1 AUTHOR
11730
11731 Andreas Koenig C<< <andk@cpan.org> >>
11732
11733 =head1 LICENSE
11734
11735 This program is free software; you can redistribute it and/or
11736 modify it under the same terms as Perl itself.
11737
11738 See L<http://www.perl.com/perl/misc/Artistic.html>
11739
11740 =head1 TRANSLATIONS
11741
11742 Kawai,Takanori provides a Japanese translation of this manpage at
11743 http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm
11744
11745 =head1 SEE ALSO
11746
11747 cpan(1), CPAN::Nox(3pm), CPAN::Version(3pm)
11748
11749 =cut
11750
11751